Gigarom 4/Mac Giga-ROM 4.0 - 1993.toast/FILES/VIR/Virus_Check/VCheck.p

Text File | 1988-04-19 | 161.3 KB | 6,070 lines | [TEXT/TPAS]

program VCheck;

(****************************************************************
Startup System Test program by Albert Lunde, Northwestern
University Copyright © 1988 - All Rights Reserved

  See "Terms of Distribution" and "Use" in comments below:
 ****************************************************************)

{$U-}   {don't use turbo pascal default units}

{$R-}   {range check off}
{**R-}  {these two strings}
{**R+}  {signal places where range checks are needed in debugging}

{$D+}   {debug symbols on}
{$B-}   {bundle bit not set}
{$S+}   {segment load on}

uses pasInout,memtypes,quickdraw,osintf,toolintf,
     fixmath,packintf,SANE;
const
  StartVersion='1.0 Beta ';
  TitleVersion=' 1.0 Beta';
  checksumsaltinc=$00010001;{change this to modify the way
                             checksums are computed}
  {constants to control what drives are checked}
  appleshareaccessmask=$00FF;{only go where owner-see IM Vol V}
                             {set $0000 to go everywhere}
  checkfloppies=false;
  checknonbootdrives=true;
(****************************************************************

Startup System Test program by Albert Lunde, Northwestern
University Copyright © 1988 - All Rights Reserved

This is a program to detect software viruses by checking for
changes in the contents of the active system folder, the boot
blocks and all applications on connected volumes.  It does
not prevent viruses from spreading in your system, but can
alert you to their existence. It is not designed to be
specific to particular viruses, except for warning of
"dangerous" resource types when found.

********************************************************************
** Warning: Beta Test Version, still has intermittent bugs 4/8/88 **
** It is suggested that you run this beta version only on a       **
** system that is well backed up and preferably with the MacsBug  **
** debugger installed. Most of the time this seems to work as     **
** designed, but there were occasional errors caught by Macsbug   **
** in recent versions.                                            **
********************************************************************
** I think these were due to problems caused by overloading the   **
** SCSI driver, and I have put in a fix for this, but I am not    **
** sure the fix works 4/14/88                                     **
********************************************************************
** The newest features are those for checking all attached disk   **
** drives, not just the boot volume. I have not had time to test  **
** these as much  4/19/88                                         **
********************************************************************

Terms of Distribution:

Non-commercial distribution is encouraged, with several
conditions:

1) You must distribute the source code if you distribute the
compiled program. (The main purpose of this is to make it
difficult for viruses to spread. Users are encouraged to
recompile from the source code, since source code cannot
carry a virus.)

2) If you modify the source code, distribute both the
original code and the modified code and include the original
comment headers with copyright notice and remarks in both files.
List a summary of your changes after the header, and add
the word "Modified" to the two Version identifiers.
You may not attach additional restrictions to
distribution of the modified code.  If I receive useful
modifications, I may add them to my versions. (Distributing
the original source makes it clearer what has been changed
and may aid support.)

3) You may change a copying fee not to exceed $10 or the cost
of media whichever is greater.  (The intent is to put
distribution of the original program and/or modified versions
into non-profit channels to allow wider distribution)  Normal
communications and connect charges for downloading software
are permitted.

Hardware and Software:

Written in Turbo Pascal 1.1 for the Mac (tested on a Mac SE
and a Mac II) this should run on a Mac Plus,Mac SE or Mac II.
I am not sure if a Mac 512E has enough memory.  This assumes
you have HFS and a relatively recent system so it is not
appropriate for the 128K or 512K Macs with the old 64K ROMs.
The program compiles and runs with Turbo 1.0 but I haven't
tested this much.

Use:

The program expects to find an input file named
"OldSystemCheckSum" in either the default folder or the
system folder.  It will optionally write an output file
(default name "NewSystemCheckSum") in the same format as the
input file.  (Both are text files with items separated by tab
characters).  The program compares the contents of your
system folder with information in the input file, and informs
you of changes. It also does a less detailed checksum of
applications. It monitors the existence of hidden files.

Use of this program does not prevent a virus infecting your
system, but it may give you an indication that you are
infected.

When the program starts you are presented with a choice of
five buttons:

"System Only" button:

          This does a complete check of the system folder,
          and do nothing with applications and hidden files
          elsewhere.

"Application Scan" button:

          This will start a complete check of the system
          folder and a check for changes in the sizes the
          resource forks of applications. After about 10
          seconds the Mac will continue as if you had clicked
          this option. This is faster but less accurate than
          the "Full Check". Because some applications write
          preferences information to their own resource fork,
          this check produces more false alarms than the
          "Full Check".

"Full Check" button:

          This does a complete check of the system folder and
          a check for changes in resources of applications.
          Only resource types marked as known to contain
          executable code are checked in applications and
          invisible files.

"Skip It" button:

          Halt the program

"ShutDown" button:

          Flush all drives and do a system shutdown. (similar
          to the item in the Finder Special Menu).


Key Commands:

     {command key ignored}
     "Q"- Quit after closing files
     "F"- same as "Full Check" button
     "A"- same as "System Only" Button
     "Y"- same as Yes Button
     "N"- same as No  Button .
     " "- Quit immediately
     "*"- invoke MacsBug debugger and turn on additional output.
     (don't use this command without a debugger)


If you hold down the option key while clicking on one if the
startup buttons, you will be given an option to create an
output file.

After the program starts, at any time you may quit the
program by clicking the "Halt" button or pressing the "Q"
key. You may shut down the system with the "Shutdown" button.

To get started:

Place the compiled program anywhere outside the system folder
and run it, clicking on "FullCheck". It may be necessary to
increase the memory allowed by MultiFinder using the Get Info
dialog. (500K is reasonable).

The first time you run it, the program will not find the
input file, and will ask you if you want to specify another
input file. Click on NO. Click YES when it asks you to
specify an output file.  When the program runs, the output
file should contain a summary of resources in the system
file of applications and hidden files. This checks all
connected disk drives, optionally excluding floppies and
folders on AppleShare file servers.

Rename this file to "OldSystemCheckSum" and place it in the
system folder or in the same folder as the program.

Now, whenever you run the program, it will the file
"OldSystemCheckSum" as a standard of comparison and inform
you of changes.  If you want maximum protection, make this
program your startup application with Set Startup.

When you install new software in the system folder or make
some changes in system settings you may get messages about
new or changed resources.  You will also get messages when
you add an application, or move, rename or duplicate an
application.

These messages will continue to appear until you create an
new output file and rename it to  "OldSystemCheckSum". The
suggested way to do this is hold down the option key while
clicking of the "FullCheck" button at startup. Running
"FullCheck" whenever you write an output file gives you the
information necessary to do a complete comparison later.

To see how the warning messages look, move some small
application into the system folder, and rerun the program.

You can see what has changed either by looking  at the on-
screen messages or by creating an output file and comparing
it with the old file. New or changed resources are flagged
"new??" or "changed??" in the output file. Deletions are not
marked. Applications are marked as "moved/renamed??',"new??",
"changed??". Hidden files are marked as "(hidden)" if they
are not applications.

To make it more difficult to evade checksums, users are
encouraged to change the value of the constant
"checksumsaltinc" from $00010001 to some other longword hex
value containing mostly zeros, but some non-zero digits in
both the lower and upper half. Changing this value changes
the non-linearity of the checksums, and changes the results,
so that a change that would be undetected for one value might
not be for another.

More about the Checksums:

In order to reduce unnecessary messages and speed processing,
some resources and some parts of the boot blocks are excluded
from the checks. Resources types are classified as:

     0 "Safe"
          (Not containing executable code)
          for example: "STR#","FONT","ICON"

     1 "Unknown"
          (Not otherwise classified)

     2 "Unsafe"
          (Containing executable code)
          for example:"CODE","INIT"

     3 "Dangerous"
          (Known only to occur in reported viruses)


"Safe" resources are excluded from system folder checksums.


Only "unsafe" resources are checked in application and hidden
files and only a file by file checksum is kept, not a
resource by resource checksum.

A basic list of resource types is in the program, and
"unknown" resources can be reclassified by changing the input
file.

There is also a list of key phrases which indicate a file in
the system folder may safely contain changes in "unknown"
resource types. If one of these keywords is found as a
substring in the filename both "safe" and "unknown" resources
are excluded from checksums. This is used to reduce
unnecessary warnings about changes in the Clipboard,
Scrapbook and settings files stored in the system folder by
applications.

A checksum of checksums is done across resource types.  This
will change when any contents of the checked resources change
or when the criteria for what is to be checked change.  This
will change when resources are deleted, while the resource by
resource lists of changes only indicate new or changed
resource.

No grand checksum is done for applications. The way that
applications are identified is by their 4 character creator
signature and creation date and time.

Hidden files are not checked for size on a short check and
they are only checked for "unsafe" resource type changes on a
full check. This is because the DeskTop and other normal
hidden files change size.

If you want to check attached floppies set the constant:
"checkfloppies=true" at the start of the program.
if you only want to check the boot drive set the constant:
"checknonbootdrives=false".

As the program is now set It only looks at the top level of
AppleShare file Servers, and does not descend into folders
unless you are the owner. The "AppleshareAccessMask" constant
controls this. The current setting is $00FF. Setting this
to $0000 will attempt to search all folders on Appleshare servers
(and very likely bring AppleTlak to its knees).
(See Inside Mac Volume V for more information. I am using the
new access information parameter returned by PBGetCatInfo.)


Disclaimers:

I do not warrant that this software will alert you to all
viruses. (It won't.) I don't claim to be an expert in
eradicating software viruses and can not do long-distance
consulting on problems with them. I have designed this
program from general considerations rather than experience
with particular viruses.

I have taken reasonable care that this program do no harm,
but I cannot assure this.  My main consideration has been to
put something together quickly to help detect viruses and
reduce their spread. Getting this out the door in time to be
useful precludes exhaustive testing.

Northwestern University Apple Tech Support is assisting in
distributing this program, but they do not take responsiblity
for its continued support.

Acknowledgements:

Thanks to Bob Hablutzel and John Norstad for their advice and support
during the development of the program.

This code owes a lot to a number of sources. My references include:

"Inside Macintosh" Volumes I to V

(A lot of use is made of the resource section and the Volume
IV parameter block file system calls}

Apple Tech Notes In particular:

67  Finding the blessed folder
68  Searching all Directories on an HFS Volume
69  Setting ioFDirIndex in PBGetCatInfo Calls
77  HFS ruminations

"MacTutor" Magazine
"Macintosh Revealed" Vol I & II by Stephen Chernicoff
"How to Write Macintosh Software" by Scott Knaster
"Macintosh Programming Secrets" by Scott Knaster
"Programming with Macintosh Programmer's Workshop" by Joel West
"Fundamentals of Data Structures" by Ellis Horowitz and Sartaj Sahni
"Programming Pearls" Jon Bentley


Bug Reporting:

    I can be reached at:

    E-Mail

        [e-mail]

        [e-mail]  (Internet)

    U.S. Mail

        Albert Lunde
        Academic Computing
        Northwestern University
        2129 Sheridan Road
        Evanston, IL 60202

    Related messages can also be sent to me care of
    Northwestern University Apple Tech Support:

        A42 - AppleLink;
            or
        76474,154   - CompuServe


If you get system bombs, record the ID number and what was
happening prior to the error.
If you have Macsbug, use "wh" to see where you are in memory.
If you have any debugger, record the registers. Since this is
a non-commercial effort, and I am giving out the source code,
whatever you can do to localize and diagnose bugs will be
appreciated.   I do not know at this time how much time I can
or will spend on support and revisions.

Notes to Hackers:

There is room for improvement here. An assembly language
checksum function could be faster.  I suggest any checksum
method should meet a few criteria: Any one bit change should
be likely to change the checksum.  Transpositions of bytes
should change the checksum. Any checksum function should be
non-linear with respect to addition and exclusive or.

That is, roughly speaking:

F(a xor b)  <>  F(a) xor F(b)

F(a + b)    <>  F(a) +   F(b)

I think my combination of shifts,xors and sums satisfies
these conditions.

The code was patched together from other projects and has
odds and ends that are unnecessary for this reason. The
checksum of applications was an afterthought that reduces the
speed, but this seemed important after the advent of viruses
that patch applications as well as the system.

I would be interested to know of conversion issues going to
other Pascal compilers. My use of Turbo's "shr" "shift
right", "xor" and other inline bit manipulation operators for
speed may cause some localized portability problems.

The program is designed over-all to make spreading viruses
more difficult, not impossible, with trade-offs relative to
speed and convenience. This is why I do a less elaborate
checksum on applications. The program does not use custom
icons or any other resources, so that it will be easier to
give out in source code form.

I am checking the contents of the resource file by reading
the resource map myself, opening the resource fork as a read-
only file. An earlier version used LoadResource and
DetachResource, but this had bugs which may come from
fragmentation of the system heap when resources were
repeatedly loaded into it.

****************************************************************)

{Development versions by Albert Lunde:}

{version 22 modified to read resource maps directly}
{this version has some bugs in memory usage that are gradually
 eating up free memory - I suspect open/close - and/or TE 4/1/88}
{version 23 the size of the TE handle is increasing but the text size is
  stating about the same , also memory allocation is a bit out of balance}
{version 24 rewrite of memory allocation to reduce the change of
  stray handles in the resource reading routines- still has trouble
  with the TE handle size 4/3/88}
{version 25 fix new TE bug by explictly changing
     the tehandle size when it gets clearly too big 4/4/88}
{version 27 hide debugging code, fix problem with ids, fix problem
     with input/output '*****' flag recognition}
{version 28 hidden "D" key to invoke Macsbug added 4/5/88}
{version 29 added relative positioning in resource reading code to
            allow buffering to work better 4/5/88}
{version 30 reduce minimum memory safety factor, hide debugging
          output 4/5/88}
{version 31 add auto-start after delay}
{version 32 cleanup for distribution, remove zero size handle check,
   add more safe keys, add beep at end  4/8/88}
{version 33 add a bit of debuggging and I/O checking 4/8/88}
{version 34 add application size checks 4/10/88}
{version 36 application checksums/detail output added but buggy 4/10/88}
{version 37 fix bugs,trim blanks before file name comparisions 4/11/88}
{version 38 shift creationdates 4 bits, modify startup interface
            this needs more testing 4/11/88}
{version 39 minor mods to application sort/compare, interface 4/12/88}
{version 40 add check of invisible files 4/14/88}
{version 41 add folder names to info on applications
            add delay after disk operations to
            fix intermittent bug in SCSI interrupt handler
            fiddle with user interface 4/14/88}
{version 42 tweak new features and revise comments 4/14/88}
{version 43 add system/only option and tweak startup 4/15/88}
{version 44 bug fix in version 43 mods, add more key abbreviations
            change debugger invocation to "*" to avoid miskeys 4/15/88}
{version 45 modify treatment of application scan output 4/16/88}
{version 46 fix minor bug in % display, clean up comments
             add PREF to safe types list  4/17/88}
{version 47  add to safe types list - display resource names 4/17/88}
{version 50 begin adding  multi-volume checks 4/18/88}
{version 51 1st version with full multi-volume checks
            seems to be working - 4/18/88}
{version 52 tweak multi-volume checks - 4/19/88}
{release as version 1.0 beta 4/19/88}

 const
    {parameters of delay to avoid overloading disk drivers}
    scsi_wait_limit=8;{wait after this many disk operations}
    scsi_wait_ticks=2;{wait this long}
    {debugging stuff}
    dbaopen=1;
    dbatype=2;
    dbaref=3;
    dbadata=4;
    dbamax=4;

 {buttons}
  mbutton=9;
  nodefaultbut=0;
  yesbut=2;
  nobut=4;
  haltbut=1;
  continuebut=3;
  shutdownbut=5;

  skipitbut=6;
  sysonlybut=7;
  shortbut=8;
 fullbut=9;


  startupdefaultbutton=shortbut;

  startupdelay=10;{seconds}

  {limits on what can be checked}
  maxinfo=800;{total resources in system folder }
  maxtype=200;{total resource types in system folder }
  maxsysfiles=100;{total files in system folder}
  maxappl=300;{total applications and hidden files}
  maxvols=16;{volumes}
  maxsafekeywords=20;
  myfilenamesize=31;
  thenamesize=10;
  maxtokens=10;{input scanner limit}
  floppycutoffsize=900;{size limit used to identify
                        floppy drives}
  {number of status lines}
  mstatus=7;
 {postions of status lines}
  titleline=1;
  byline=2;
  pathline=3;
  fileline=4;
  errorline=5;
  memline=5;
  AskLine=6;
  resline=6;

  {rescaling of creation dates by factor of 1/16}
  creationdateshr=4;
  creationdatemask=$0FFFFFFF;

  {resource match flags}
  fnamemask=$3FFF;{mask off top bits of filename index}
  idmatchmask=$8000;
  exactmatchmask=$4000;

  {application match flags}
  applrenamemask=$0100;
  applexactmatchmask=$0200;
  applchangedmask=$0400;
  appldangermask=$0800;
  applbadsizemask=$1000;
  applbadcheckmask=$2000;
  applinvisiblemask=$4000;{flag invisible files}
  applvolumemask=$00FF;{subscript of volume}
  notcounted=-9;{flag results of short check in unsafecount}

  {grow zone function guard block size:
  This block is released if the heap is full and the
  program stops with a warning. Reducing this would make the program
  run in less memory but if it runs out it would die unpleasantly}

  GZguardblocksize=70000;

     {stuff from tech note#77}

        SysWDProcID    = $4552494B;    {“ERIK”}
        BootDrive       = $210;    {address of Low-Mem global BootDrive}
        FSFCBLen    = $3F6;      {address of Low-Mem global to distinguish file systems }
        SysMap        = $A58;    {address of Low-Mem global that contains system map reference number}

  type
      myfilenametype=string[myfilenamesize];
            WordPtr = ^Integer;            {Pointer to a word(2 bytes)}

      {info on system folder resources}
      resourceinforec  = record
                         thesize:longint;
                         thetype:restype;
                         theid:integer;
                         filenameindex:integer;{also flags in the high bits}
                         checksum:integer;
                         thename:string[thenamesize];
                         end;
      resourceinfoarray=array[1..maxinfo] of resourceinforec;
      resourceinfoarrayptr=^resourceinfoarray;
      safetype=(safe,unknown,unsafe,dangerous);
      resourcetypeinforec = record
                            thetype:restype;
                            safety:safetype;
                            occurs:integer;
                            oldocurrs:integer;
                            end;
      resourcetypeinfoarray = array[1..maxtype] of resourcetypeinforec;
      tokenstype=array[1..maxtokens] of str255;
      {info on volumes}

       myvolumerec= record
                      volrefnum:integer;
                      vcreation:longint;
                      vname:myfilenametype;{change this}
                      vsize:longint;
                      vindex:integer;
                      isboot:boolean;
                      attributes:integer;
                      matchto:integer;
                      checkvol:boolean;
                      end;

       myvolumearraytype=array[1..maxvols] of myvolumerec;

      {info on applications and hidden files}
      applinforec=record
                  thesize:longint;
                  creator:OStype;
                  creationdate:longint;{shifted right}
                  dirid:longint;
                  filename:myfilenametype;
                  unsafecount:integer;
                  checksum:integer;
                  checksize:longint;
                  flags:integer;
                  end;

      applinfoarray=array[1..maxappl] of applinforec;
      applinfoarrayptr=^applinfoarray;

      {Types for directly reading resource maps}

type
             myresstatustype=(pathbad,pathempty,pathopen,
                              typelistopen,reflistopen);


             {resource map}
             myresMaptype=record
                               dummy1:array[1..5] of longint;
                               dummy2:integer;
                               res_file_attributes:integer;
                               offset_map_to_typelist:integer;
                               offset_map_to_namelist:integer;
                               end;

             {resource type list items}
             myresTypeListitemtype=record
                               thetype:restype;
                               count_minus_one:integer;
                               offset_typelist_to_reflist:integer;
                               end;

             myresTypeList=array[0..0] of myresTypeListitemtype;
             myresTypeListptr=^myresTypeList;
             myresTypeListhandle=^myresTypeListptr;

             {resource reference list items}
             myresRefListitemtype=record
                               theid:integer;
                               offset_namelist_to_name:integer;
                               attrib_and_offset:longint;
                               dummy1:longint;
                               end;

             myresreflisttype=array[0..0] of myresRefListitemtype;
             myresreflistptr=^myresreflisttype;
             myresreflisthandle=^myresreflistptr;

             {My "path" to the resource data. This includes
              some redundant information and buffer space}
             myresPathtype=record
                         volref:integer;
                         fileref:integer;
                         filename:str255;
                         {absolute offsets}
                         offset_to_res_data:longint;
                         offset_to_res_map:longint;
                         offset_to_typelist:longint;{derived}
                         offset_to_namelist:longint;{derived}
                         map:myresmaptype;
                         typelist:myresTypeListHandle;
                         reflist:myresReflistHandle;
                         resdata:handle;
                         current_type:restype;
                         current_type_subscript:integer;
                         status:myresstatustype;{state of path}
                         ntypes:integer;{number of types}
                         nrefs:integer;{number of references to current type}
                         end;

var
    scsi_wait_count:longint;
    currentvolumesubscript:integer;
    myRpath:myresPathtype;
    showdebuginfo:boolean;
    fastapplcheck:boolean;
    skipapplcheck:boolean;
    dbarray:array[1..dbamax] of longint;{for debug}
    notsafecount:longint;{number of resources not in a safe category}
    safetynames:array[safe..dangerous] of string[10];
    blessed:longint;{dir id of the blessed folder}
    blessedpath:str255;{path name of blessed folder}
    blessedbootvolwd:integer;
    startupwd:integer;{working directory on startup}
    buttons:array[1..mbutton] of controlhandle;
    buttonrects:array[1..mbutton] of rect;
    defaultbutton:integer;
    quitting,finished:boolean;
    bootblockchecksum,oldbootblockchecksum:integer;
    checksumchecksum,oldchecksumchecksum:longint;
    askanswer:boolean;{answer from yes,no buttons}
    askanswered:boolean;{set true when button clicked}
    optionkeyflag:boolean;
    WriteOutputFlag:boolean;
    {event handler globals}
    theevent:   EventRecord;
    mainwindow:Windowptr;
    wbounds,textbounds,textframe:rect;
    statustext:tehandle;

    rcount:longint;{count of resources checked in system folder}
    acount:longint;{count of apps and hidden files}
    oldvcount,vcount:integer;{count of volumes}
    oldvols,newvols:myvolumearraytype;{lists of volumes checked}

    {pointers to the two big blocks of memory which are seperately
     allocated to reduced the total size of globals}
    rinfo:resourceinfoarrayptr;
    ainfo:applinfoarrayptr;

    rtypes:resourcetypeinfoarray;
    rtypes_count:integer;

    infile,outfile:text;
    inputopen,outputopen,inputnotdefault:boolean;

    line,filename,filedef : str255;
    fileref,volref:integer;
    blanks,procname:str255;
    cancel:boolean;
    currentresourcefileopen:integer;
    sysfiles:array[1..maxsysfiles] of myfilenametype;

    safekeywords_count:integer;
    safekeywords:array[1..maxsafekeywords] of myfilenametype;

    {Mydebug message globals}
    mydebugport : grafptr;

    {growzone function stuff}
    growzoneguardblock:handle;
    lowmemoryGZflag:boolean;


{forward procedure declarations, not in any
particular order}

procedure debugger;inline $A9FF;{invoke macsbug}
procedure debugStr(str:str255);inline $ABFF;{macsbug with string}
procedure halt_on_error(err:oserr;sss:str255);forward;
procedure detail_appl_check;forward;
procedure show_appl_detail_changes;forward;

procedure Doevent(dontloop:boolean);forward;

{ ShutDown is new, but works with all machines with new system. }
PROCEDURE ShutDwnPower;
    INLINE $3F3C,$0001,$A895;

procedure check_a_file(index:integer);forward;
procedure checksum_all_appl;forward;
procedure poststatus(ss:str255;linenum:integer);forward;
procedure replaceline(ss:str255;linenum:integer);forward;
procedure dobutton(whichbutton:integer);forward;
procedure drawbuttons;forward;
procedure showstatus;forward;
procedure close_all_and_halt(beep:boolean);forward;
procedure folder_name(dirid:longint;var name:str255);forward;

function Ask(question:str255;default:integer):boolean;forward;
procedure wait_for_buttons(ss:str255;default:integer);forward;
procedure clear_to_end(linenum:integer);forward;
procedure summary;forward;
procedure set_default_blessed;forward;
procedure set_default_by_id(DirID:longint);forward;
function checksumHdataOLD(h:handle):integer;forward;
function checksumHdata(h:handle):integer;forward;
function checksum_boot_blocks:integer;forward;
procedure sorttypes(var X:resourcetypeinfoarray;N:integer);forward;
procedure tabscan(line:str255; var tokens:tokenstype;var ntokens:integer);forward;
procedure filltype(var tt:restype;ss:str255);forward;
procedure open_output;forward;
procedure open_input;forward;
procedure get_set_blessed;forward;

procedure setupmydebug;{setup extra graphics port
for drawing direct to the screen without using the window manager}
const  dbtop=260;
       dbleft=40;
       dbwidth=200;
       dblength=50;

var    saveport:grafptr;
       dbrect : rect;
       begin
       getport(saveport);{save current port}
     mydebugport:=grafptr(NewPtr(sizeof(grafport)));
     {make non-relocatable block}
     openport(mydebugport);
       setorigin(-dbleft,-dbtop);
       {set new origin so (0,0) is at (dbleft,dbtop)
                         on the screen }
       (*debug_mess('Start Debug');*)
       setport(saveport);{restore current port}
end; {of proc mysetup debug}
procedure debug_mess(message:str255);
const  dbtop=260;
       dbleft=40;
       dbwidth=200;
       dblength=50;
       waitsec=2;

var    saveport:grafptr;
       dbrect : rect;
       waittick,dumm:longint;
begin

{---------------------------}
getport(saveport);{save current port}
setport(mydebugport);{change to debug port}
       setrect(dbrect,0,0,dbwidth,dblength);
       fillrect(dbrect,Dkgray); {draw a pseudo-window} {make this fancer later}
       penpat(white);
       framerect(dbrect);
       moveto(20,20);
       TextMode(Srcbic);{white letters}
       DrawString(message);
       waittick:=60*waitsec;
       delay(waittick,dumm);
setport(saveport);{restore current port}
{-------------------------}

end; {of function debug_message}
procedure debug_long(l:longint;tag:str255);
var ss:str255;
begin
numtostring(l,ss);
ss:=concat(tag,ss);
debug_mess(ss);
end;

{---memory management tools---}
function GoodPointer(p:ptr;tag:str255):boolean;
{check that this is a pointer to non-nil data
within the application memory area}
const
      CurrentA5=$0904;
      ApplZone=$02AA;
      Lo3Bytes=$00FFFFFF;
type
        lp=^longint;

var     a:lp;
        high,low,add:longint;
        ok:boolean;
begin
ok:=false;
   if p<>nil then
     begin
     add:=longint(ord4(p) and Lo3bytes);
     if not odd(add)then
        begin
          {this test is a bit strict/mem-map dependent}
          a:=pointer(ApplZone);
          low:=a^;
          a:=pointer(CurrentA5);
          high:=a^;
          if (add>=low) and (add<high) then
              begin
                  ok:=true;
              end
          else
              begin
                 debug_mess('Pointer outside User Memory');
                sysbeep(5);sysbeep(5);
              end;
        end
      else
        begin
           debug_mess('Pointer With Odd Address');
        end
      ;{endif}

     end;
if not ok and (p<>nil) then
     begin
     debug_mess(concat('GP>',tag));
     repeat until button;
     end;
Goodpointer:=ok;
end;{goodPointer}
function GoodHandle(h:handle;tag:str255):boolean;
var     a:ptr;
        ok:boolean;

begin
ok:=false;
   if GoodPointer(ptr(h),concat('GH1:',tag)) then
        begin
        if GoodPointer(h^,concat('GH2:',tag)) then
           begin
           {if GetHandleSize(h) >0 then}
               begin;
                  ok:=true
               end
           {else
              begin
                debug_mess('Handle Size<0');
              end}
           ;{endif}
           end

         else
           begin
              debug_mess('Handle^ is bad or nil');
           end
         ;{end if}
         end
     else
        begin
           if h<>nil then
           debug_mess('Handle is bad');
        end
     ;{endif}

if not ok and (h<>nil) then
    begin
    debug_mess(concat('GH>',tag));
    repeat until button;
    end;

GoodHandle:=ok;
end;{goodhandle}

procedure scsi_wait;
{periodic delays to keep from overwhelming the scsi driver}
var wait,endit:longint;
begin
scsi_wait_count:=scsi_wait_count+1;
if scsi_wait_count>scsi_wait_limit then
  begin
    wait:=scsi_wait_ticks;
    delay(wait,endit);
    scsi_wait_count:=0;
  end;
end;

procedure read_input(var line:str255);
{readln(infile,line) with delay added}
begin
scsi_wait;
readln(infile,line);
end;{proc}
procedure read_input_integer(var ii:integer);
var ss:str255;
    work:longint;
begin
read_input(ss);
stringtonum(ss,work);
ii:=work;
end;{proc}

procedure read_input_long(var jj:longint);
var ss:str255;
begin
read_input(ss);
stringtonum(ss,jj);
end;{proc}
procedure kill_nil;
{for debugging}
{put an odd value in memory location zero to hit nil's early}
type lptr=^longint;
var     p:lptr;
begin
p:=lptr(Pointer(0));
P^:=$4E494C21;{NIL!}
end;
procedure myteshow;
var i,nn,jj:integer;
    ss,ww:str255;
begin
    nn:=statustext^^.nlines;
    ss:='';
    for i:=0 to nn do
       begin
       jj:=statustext^^.linestarts[i];
      numtostring(jj,ww);
      ss:=concat(concat(ss,ww),' ');
      end;
      numtostring(statustext^^.telength,ww);
      ss:=concat(concat(ss,ww),' ');
   poststatus(ss,byline);

end;{proc}

procedure dbashow;
var i:integer;
    ss,nn:str255;
begin
   myteshow;
   ss:='';
   for i:=1 to dbamax do
      begin
      numtostring(dbarray[i],nn);
      ss:=concat(concat(ss,nn),' ');
      end;
      numtostring(statustext^^.nlines,nn);
      ss:=concat(concat(ss,nn),' ');

   poststatus(ss,pathline);
end;{proc}

{$S core}
procedure write_end_flag(tag:str255);
var tab:char;
begin
if not outputopen then exit;
tab:=chr(9);
scsi_wait;
writeln(outfile,'*****',tab,tag);
end;{proc}

function test_end_flag(line:str255):boolean;
begin
test_end_flag:=copy(line,1,5)='*****';
end;{function}

function filenamecompare(aa,bb:myfilenametype):integer;
{compare filenames after trimming leading and trailing blanks}
{and mapping to uppercase}
{metaphore is sign of aa-bb
 if aa<bb return -1
 if aa=bb return 0
 if aa>bb return 1}
 label 10,20,30,40;
 var result:integer;
     w:str255;
begin
{while loops to trim blanks}
10:if aa<>'' then
     if aa[1]=' ' then
        begin
        aa:=copy(aa,2,length(aa)-1);
        goto 10;
        end;
20:if aa<>'' then
     if aa[length(aa)]=' ' then
        begin
        aa:=copy(aa,1,length(aa)-1);
        goto 20;
        end;
{while loops to trim blanks}
30:if bb<>'' then
     if bb[1]=' ' then
        begin
        bb:=copy(bb,2,length(bb)-1);
        goto 30;
        end;
40:if bb<>'' then
     if bb[length(bb)]=' ' then
        begin
        bb:=copy(bb,1,length(bb)-1);
        goto 40;
        end;
w:=aa;
uprstring(w,true);
aa:=w;
w:=bb;
uprstring(w,true);
bb:=w;
if aa=bb then
    result:=0
else if aa>bb then
    result:=1
else
    result:=-1;
filenamecompare:=result;
end;

{$S vols}
procedure find_vols;
label 88;
var
  mypb:hparamblockrec;
  name:str255;
  err:oserr;
  index:integer;

begin
vcount:=0;
index:=0;
repeat
  index:=index+1;
  with mypb do
      begin
      iocompletion:=nil;
      name:='';
      ionameptr:=@name;
      iovrefnum:=0;
      iovolindex:=index;
      end;
  err:=pbhgetvinfo(@mypb,false);

  if err=noerr then
     begin
     if vcount>=maxvols then goto 88;
     vcount:=vcount+1;
     with newvols[vcount] do
     with mypb do
         begin
           volrefnum:=iovrefnum;
           vindex:=index;
           vname:=name;
           {compute size to the nearest K}
           vsize:=round((float(abs((longint(iovNmAlblks) and $0000FFFF)))*float(ioVAlBlkSiz))/1024);
           {shifted creation date}
           vcreation:=(iovcrdate shr creationdateshr) and creationdatemask;
           isboot:=(blessedbootvolwd=volrefnum);
           attributes:=iovAtrb;
           matchto:=0;
           checkvol:=true;
           if not checkfloppies then
              if vsize<floppycutoffsize then
                  begin
                     {skip floppies}
                     checkvol:=false;
                  end;
          if not checknonbootdrives then
              if not isboot then
                  begin
                    {skip non-boot drives}
                     checkvol:=false;
           end;

          end;
     end;

until(err<>noerr);
88:
end;{find_vols}

procedure write_vols;
var i:integer;
    tab:string[1];
begin
tab:=chr(9);
if not outputopen then exit;
for i:=1 to vcount do
    with newvols[i] do
      begin
        scsi_wait;
        writeln(outfile,vname,tab,vsize,tab,vcreation,tab,ord(isboot));
      end;
write_end_flag('end volumes');
end;{procedure write_vols}

procedure read_vols;
var line:str255;
    tokens:tokenstype;
    ntokens:integer;
    work:longint;
begin
oldvcount:=0;
if not inputopen then exit;
while not eof(infile) do
    begin
    read_input(line);
    if test_end_flag(line) then exit;
    tabscan(line,tokens,ntokens);
    if ntokens>=4 then
       begin
         oldvcount:=oldvcount+1;
         with oldvols[oldvcount] do
            begin
              vname:=tokens[1];
              stringtonum(tokens[2],vsize);
              stringtonum(tokens[3],vcreation);
              stringtonum(tokens[4],work);
              isboot:=boolean(ord(work));
              matchto:=0;
              {unused stuff}
               volrefnum:=0;
               vindex:=0;
               attributes:=0;
            end;
       end;
    end;

end;

procedure match_vols;
{decide what old volumes match what new volumes}
{this trys to match in several ways}
var iold,inew:integer;
    ccount:longint;
    nomatch:longint;
    w1,w2:str255;
begin
if oldvcount<=0 then exit;
if ((oldvcount=1) and (vcount=1)) then
   begin
   {if one vol, always match}
   oldvols[1].matchto:=1;
   newvols[1].matchto:=1;
   exit;
   end;

{check for exact matches first}
for inew:=1 to vcount do
   if newvols[inew].matchto=0 then
   begin
   for iold:=1 to oldvcount do
      if oldvols[iold].matchto=0 then
      begin
       if (filenamecompare(oldvols[iold].vname,newvols[inew].vname)=0) then
        if oldvols[iold].vsize=newvols[inew].vsize then
          if oldvols[iold].vcreation=newvols[inew].vcreation then
             begin
             oldvols[iold].matchto:=inew;
             newvols[inew].matchto:=iold;
             end;{if match}
      end;{for/if}
   end;{for/if}

{check for matches ignoring name}
{this assumes a rename may happen}
for inew:=1 to vcount do
   if newvols[inew].matchto=0 then
   begin
   for iold:=1 to oldvcount do
      if oldvols[iold].matchto=0 then
      begin
        if oldvols[iold].vsize=newvols[inew].vsize then
          if oldvols[iold].vcreation=newvols[inew].vcreation then
             begin
             oldvols[iold].matchto:=inew;
             newvols[inew].matchto:=iold;
             end;{if match}
      end;{for/if}
   end;{for/if}

{match by name only}
{this will match a volume that has been reinitialized
 with the same name}
for inew:=1 to vcount do
   if newvols[inew].matchto=0 then
   begin
   for iold:=1 to oldvcount do
      if oldvols[iold].matchto=0 then
      begin
       if (filenamecompare(oldvols[iold].vname,newvols[inew].vname)=0) then
        if oldvols[iold].vsize=newvols[inew].vsize then
          if oldvols[iold].vcreation=newvols[inew].vcreation then
             begin
             oldvols[iold].matchto:=inew;
             newvols[inew].matchto:=iold;
             end;{if match}
      end;{for/if}
   end;{for/if}

nomatch:=0;
ccount:=0;
for inew:=1 to vcount do
   if newvols[inew].checkvol then
    begin
    ccount:=ccount+1;
       if newvols[inew].matchto=0 then
                  nomatch:=nomatch+1;
    end;
if nomatch=0 then exit;
if not inputopen then exit;
numtostring(nomatch,w1);
numtostring(ccount,w2);
w1:=concat(concat(concat(concat(concat('Note: ',w1),' of '),w2),
' mounted disk volumes to be checked do not match any in the input file. '),
 'No application changes will be reported on these volumes.');
wait_for_buttons(w1,continuebut);
end;{procedure}

{$S vols}
        procedure sortnewvols(var X:myvolumearraytype;N:integer);
        {sort array of volumes in a consistent but arbitrary order}
        {this is done after matching with old volumes to put the
        new volumes in the same order, except for mismatches}

{        HEAP SORT
C
C       BASED ON PROGRAMMING PEARLS BY JON BENTLEY P 182
C       X IS THE ARRAY CONTAINING NX ELEMENTS TO BE SORTED
C       CALL SWAPX(I,J) SWAPS X(I) WITH X(J)
C       GEX(X,I,J) IS TRUE IFF X(I) >= X(J)
C       GTX(X,I,J) IS TRUE IFF X(I) > X(J)
C}


       var i: integer;


procedure SWAPX(I:integer;J:integer);
var     T:myvolumerec;
{swap new vols and update matchto fields in new vols}
begin
        T:=X[I];
        X[I]:=X[J];
        X[J]:=T;

        IF X[I].matchto<>0 then
            oldvols[X[I].matchto].matchto:=I;
        IF X[J].matchto<>0 then
            oldvols[X[J].matchto].matchto:=J;

END; {of procedure swapx}

FUNCTION GTX(I:integer;J:integer):boolean;
var filecomp:integer;
begin
       {sort by order of matches then index }
       gtx:=false;

       if (X[I].matchto>X[J].matchto) then
          begin
           gtx:=true
          end
       else if (X[I].matchto=X[J].matchto) then
          begin
            if (X[I].vindex>X[J].vindex)then
                begin
                    gtx:=true;
                end;
           end;

end;

FUNCTION GEX(I:integer;J:integer):boolean;
var filecomp:integer;
begin
       {sort by order of matches then index }
       gex:=false;

       if (X[I].matchto>X[J].matchto) then
          begin
           gex:=true
          end
       else if (X[I].matchto=X[J].matchto) then
          begin
            if (X[I].vindex>=X[J].vindex)then
                begin
                    gex:=true;
                end;
           end;

END;

procedure siftdown(L:integer;U:integer);
    label 300,999{return};
    var
        i,child:integer;

begin

{
C
C       BEFORE MAXHEAP(L+1,U)
C       AFTER  MAXHEAP(L,U)
}
        I:=L;

        {LOOP}
300:
{
C               INVARIANT: MAXHEAP(L,U) EXCEPT PERHAPS
C                       BETWEEN I AND ITS (0,1 OR 2) CHILDREN
C
}
                CHILD:=2*I;

                IF CHILD > U  then goto 999;
{
C
C               IF C+1 <= U AND X(C+1) > X(C) THEN C=C+1
C
}
                IF(CHILD+1 <= U) THEN
                IF(GTX(CHILD+1,CHILD))THEN
                        CHILD:=CHILD+1;

{
C
C               CHILD IS THE GREATEST CHILD OF I
C
C               IF X(I) >= X(CHILD) THEN RETURN
C
}
                IF(GEX(I,CHILD)) then goto 999;

{
C
C               X(I) IS LESS THAN ITS GREATEST CHILD SO SWAP IT DOWNWARD
C               AND REPEAT LOOP
C
}
                SWAPX(CHILD,I);
                I:=CHILD;
                GOTO 300;
        {END LOOP}
999:{return}
END; {of proc siftdown}



begin {main body of sortnewvols}

        for I:=N div 2 downto 1 do
        begin
       { echo(i);}
        SIFTDOWN(I,N);
        end;

        {echo(0);}

        for I:=N downto 2 do
        begin
          {  echo(i);}
                SWAPX(1,I);
                {echo(i);}
                SIFTDOWN(1,I-1);
               { echo(i);}
         end;



END; {sortnewvols}

procedure dovols;
{multi-volume processing}
begin
find_vols;
read_vols;
match_vols;
sortnewvols(newvols,vcount);
end;

{$S appl}
procedure note_application( fname:str255;
                            pdirID:longint;
                            index:integer;
                            mycpb:CInfoPBRec;
                            hidden:boolean);

 (*
       {info on applications}
      applinforec=record
                  thesize:longint;
                  creator:OStype;
                  creationdate:longint;
                  dirid:longint;
                  filename:myfilenametype;
                  unsafecount:integer;
                  checksum:integer;
                  fileindex:integer;
                  flags:integer;
                  end;

      applinfoarray=array[1..maxappl] of applinforec;
      applinfoarrayptr=^applinfoarray;

 *)
{add to a list of applications in memory}
begin
if acount<maxappl then
  begin
     poststatus(fname,fileline);
     acount:=acount+1;
     with ainfo^[acount] do
        begin
        flags:=currentvolumesubscript and applvolumemask;{save volume}
        checksum:=0;
        checksize:=0;
        if fastapplcheck then
           unsafecount:=notcounted
        else
           unsafecount:=0;
        filename:=fname;
        dirid:=pdirid;
        if hidden then
           begin
             {make as hidden non-application file}
              flags:=flags or applInvisiblemask;
           end;
        with mycpb do
          begin
             thesize:=ioflRLgLen;{logical size of resource fork}
             creationdate:=(ioflcrdat shr creationdateshr) and creationdatemask;
             {creation date and time}
             creator:=ioFlFndrInfo.fdcreator;
          end;{with}
        end;{with}
  end
else
  begin
   poststatus('Max applications exceeded.',errorline);
  end;
end;{procedure}

PROCEDURE EnumerAPPLShell;
{search applications on current default volume staring with root}
VAR

      myCPB: CInfoPBRec;
      err: OSErr;
      myWDPB: WDPBRec;
   DirIDToSearch:Longint;
   fname:str255;
   p:wordptr;
   accessrights:integer;

PROCEDURE EnumerateAPPLCatalog(dirIDToSearch: longint);

VAR
  index:    integer;



Begin {EnumerateAPPLCatalog}

    index:= 1;

    repeat

        FName:= '';  {nil out name}
        myCPB.ioFDirIndex:= index;
        myCPB.ioDrDirID:= dirIDToSearch; {we need to do this every time through}
  p:=@mycpb.ioflAttrib;{clear word with appleshare permissions in 2nd byte}
  p^:=0;

        err:= PBGetCatInfo(@myCPB,FALSE);


        If err = noErr then

            if BitTst(@myCPB.ioFlAttrib,3) then
      Begin
       {we have a dir}
          p:=@mycpb.ioflAttrib;{appleshare permissions are at offset 31}
          accessrights:=p^ and $00FF;
          if (accessrights and appleshareaccessmask)=0 then
             begin
             {only descend tree if we have specified rights}
                      EnumerateAPPLCatalog(myCPB.ioDrDirID);
             end;
                 err:= 0;  {clear error return on way back}
            End {if dir}
         Else
      Begin
        {we have a file}
        {test if application or invisible file}
        if (myCPB.ioFlFndrInfo.fdtype='APPL')then
             begin
               {It is an application, add it to list in memory}
               note_application(fname,dirIDToSearch,index,mycpb,false)
               end
        else if (myCPB.ioFlFndrInfo.fdflags and fInvisible)<>0 then
             begin
               {It is a hidden file add it to list in memory}
               note_application(fname,dirIDToSearch,index,mycpb,true)
             end;
            End; {end if}

        index:= index + 1;

until err <> noErr;

End;  {EnumerateAPPLCatalog}



Begin {EnumerAPPLShell}

DirIDToSearch:=2;{root}

    err:= PBHGetVol(@myWDPB,FALSE);        {get the default volume}

    with MyCPB do Begin
        iocompletion:= Nil;
        ioNamePtr:= @FName;
        ioVRefNum:= myWDPB.ioVRefNum;      {for now, default vol, set this to what you want}
    End;  {with}

    EnumerateAPPLCatalog(DIRIDTOSEARCH);{DirID 2, is the root level}

End;  {procedure EnumerAPPLShell}

        procedure sortapplications(var X:applinfoarrayptr;N:integer);
        {sort array of applications and their checksums}
{        HEAP SORT
C
C       BASED ON PROGRAMMING PEARLS BY JON BENTLEY P 182
C       X IS THE ARRAY CONTAINING NX ELEMENTS TO BE SORTED
C       CALL SWAPX(I,J) SWAPS X(I) WITH X(J)
C       GEX(X,I,J) IS TRUE IFF X(I) >= X(J)
C       GTX(X,I,J) IS TRUE IFF X(I) > X(J)
C}


       var i: integer;


procedure SWAPX(I:integer;J:integer);
var     T:applinforec;

begin
        T:=X^[I];
        X^[I]:=X^[J];
        X^[J]:=T;
END; {of procedure swapx}

FUNCTION GTX(I:integer;J:integer):boolean;
var filecomp:integer;
begin
   {sort by creator signature,creation date,filename,volume,dirID}
   gtx:=false;
   if (X^[I].creator>X^[J].creator) then
      begin{1}
        gtx:=true;
      end{1}
   else if (X^[I].creator=X^[J].creator) then
      begin{2}
        if (X^[I].creationdate>X^[J].creationdate) then
           begin{3}
             gtx:=true;
           end{3}
        else if (X^[I].creationdate=X^[J].creationdate) then
           begin{4}
             filecomp:=filenamecompare(X^[I].filename,X^[J].filename);
             if filecomp>0{(X^[I].filename>X^[J].filename)} then
                begin{5}
                  gtx:=true;
                end{5}
             else if filecomp=0{(X^[I].filename=X^[J].filename)} then
                 begin{6}
                  if (X^[I].flags and applvolumemask)>(X^[J].flags and applvolumemask) then
                      begin{7}
                         gtx:=true;
                      end{7}
                  else if (X^[I].flags and applvolumemask)=(X^[J].flags and applvolumemask) then
                     begin{8}
                       if (X^[I].dirID>X^[J].dirID) then
                       begin{9}
                          gtx:=true;
                       end;{9}
                     end;{8}
                  end;{6}
              end;{4}
         end;{2}

end;

FUNCTION GEX(I:integer;J:integer):boolean;
var filecomp:integer;
begin
   {sort by creator signature,creation date,filename,volume,dirID}
   gex:=false;
   if (X^[I].creator>X^[J].creator) then
      begin{1}
        gex:=true;
      end{1}
   else if (X^[I].creator=X^[J].creator) then
      begin{2}
        if (X^[I].creationdate>X^[J].creationdate) then
           begin{3}
             gex:=true;
           end{3}
        else if (X^[I].creationdate=X^[J].creationdate) then
           begin{4}
             filecomp:=filenamecompare(X^[I].filename,X^[J].filename);
             if filecomp>0{(X^[I].filename>X^[J].filename)} then
                begin{5}
                  gex:=true;
                end{5}
             else if filecomp=0{(X^[I].filename=X^[J].filename)} then
                 begin{6}
                  if (X^[I].flags and applvolumemask)>(X^[J].flags and applvolumemask) then
                      begin{7}
                         gex:=true;
                      end{7}
                  else if (X^[I].flags and applvolumemask)=(X^[J].flags and applvolumemask) then
                     begin{8}
                       if (X^[I].dirID>=X^[J].dirID) then
                       begin{9}
                          gex:=true;
                       end;{9}
                     end;{8}
                  end;{6}
              end;{4}
         end;{2}

END;

procedure siftdown(L:integer;U:integer);
    label 300,999{return};
    var
        i,child:integer;

begin

{
C
C       BEFORE MAXHEAP(L+1,U)
C       AFTER  MAXHEAP(L,U)
}
        I:=L;

        {LOOP}
300:
{
C               INVARIANT: MAXHEAP(L,U) EXCEPT PERHAPS
C                       BETWEEN I AND ITS (0,1 OR 2) CHILDREN
C
}
                CHILD:=2*I;

                IF CHILD > U  then goto 999;
{
C
C               IF C+1 <= U AND X^(C+1) > X^(C) THEN C=C+1
C
}
                IF(CHILD+1 <= U) THEN
                IF(GTX(CHILD+1,CHILD))THEN
                        CHILD:=CHILD+1;

{
C
C               CHILD IS THE GREATEST CHILD OF I
C
C               IF X^(I) >= X^(CHILD) THEN RETURN
C
}
                IF(GEX(I,CHILD)) then goto 999;

{
C
C               X^(I) IS LESS THAN ITS GREATEST CHILD SO SWAP IT DOWNWARD
C               AND REPEAT LOOP
C
}
                SWAPX(CHILD,I);
                I:=CHILD;
                GOTO 300;
        {END LOOP}
999:{return}
END; {of proc siftdown}



begin {main body of sortapplications}

        for I:=N div 2 downto 1 do
        begin
       { echo(i);}
        SIFTDOWN(I,N);
        end;

        {echo(0);}

        for I:=N downto 2 do
        begin
          {  echo(i);}
                SWAPX(1,I);
                {echo(i);}
                SIFTDOWN(1,I-1);
               { echo(i);}
         end;



END; {sortapplications}

procedure APPLsummary;
{write summary of info on applications}
var i:integer;
    tab:char;
    tags:str255;
    dname:str255;
begin
set_default_blessed;
tab:=chr(9);
if not outputopen then exit;
poststatus('Writing Application Summary Output',pathline);
for i:=1 to acount do
  with ainfo^[i] do
     begin
         dname:='?';
         folder_name(dirid,dname);
         tags:='';
         if inputopen then
         begin
           if (flags and applexactmatchmask)<>applexactmatchmask then
             begin
             if (flags and applrenamemask)=applrenamemask then
                begin
                   {moved or renamed or duplicated}
                   tags:='moved/renamed??';
                end
             else
                begin
                  if (flags and applchangedmask)=applchangedmask then
                    begin
                      {changed}
                      tags:='changed??';
                    end
                  else
                    begin
                       {"new"}
                       tags:='new??';
                    end
                end;
            end;
            if (flags and appldangermask)=appldangermask then
                begin
                   tags:=concat(tags,' Danger??');
                end;
          end;{inputopen}
          if (flags and applinvisiblemask)<>0 then
                 begin
                   tags:=concat(tags,'(hidden)');
                 end;
      scsi_wait;
      write(outfile,creator:4,tab,
                      creationdate,tab,
                      filename,tab,
                      dirid,tab,
                      (flags and applvolumemask),tab,
                      thesize,tab,
                      unsafecount,tab,
                      checksize,tab,
                      checksum,tab,
                      dname);
      scsi_wait;
     if tags='' then writeln(outfile) else writeln(outfile,tab,tags);

     end;{for/with}

write_end_flag('end applications and hidden files');
end;{applsummary}

procedure copyapplsummary;
{copy old applications summary when no application checks are done}
label 88;
var line:str255;

begin
if not outputopen then exit;

if inputopen then
   begin
      while(not(eof(infile))) do
         begin
          read_input(line);
          if test_end_flag(line) then goto 88;
          scsi_wait;
          writeln(outfile,line);
         end;
      88:
   end;
write_end_flag('end applications and hidden files(copy)');
end;

procedure scan_all_vols;
label 88;
var i:integer;
    err:oserr;
begin
for i:=1 to vcount do
   begin
   if newvols[i].checkvol then
      begin
      err:=setvol(nil,newvols[i].volrefnum);
      if err=noerr then
           begin
           poststatus(concat('Scan applications and hidden files:',newvols[i].vname),pathline);
           currentvolumesubscript:=i;
           enumerAPPLshell;
           end;
      end;
   end;

set_default_blessed;
end;

procedure docheck_applications;

begin
set_default_blessed;
acount:=0;
clear_to_end(pathline);
scan_all_vols;

clear_to_end(fileline);
poststatus('Checksum applications',pathline);
checksum_all_appl;
clear_to_end(pathline);
Poststatus('Sort Application info',pathline);
sortapplications(ainfo,acount);
if fastapplcheck then
        poststatus('Compare application sizes',pathline)
else
        poststatus('Compare application resource checks',pathline);
clear_to_end(fileline);
detail_appl_check;
set_default_blessed;
clear_to_end(pathline);
show_appl_detail_changes;
end;{procedure}


{$S myres}
procedure initmypath(var mypath:myresPathtype);
const bigneg=-16000;
      startsize=32;
begin
with mypath do
   begin
   volref:=0;
   fileref:=0;
   filename:='';
   {absolute offsets}
   offset_to_res_data:=bigneg;
   offset_to_res_map:=bigneg;
   offset_to_typelist:=bigneg;{derived}
   offset_to_namelist:=bigneg;{derived}
   typelist:=myresTypeListHandle(newhandle(startsize));
   reflist:=myresReflistHandle(newhandle(startsize));
   resdata:=newhandle(startsize);
   current_type:='    ';
   current_type_subscript:=0;
   status:=pathbad;{state of path}
   ntypes:=0;{number of types}
   nrefs:=0;{number of references to current type}
   end;

end;{proc}
function my_openRF_readonly(filename:str255;
         vrefnum:integer; var refnum:integer):oserr;

{Open Resource File - as a file - read only}

var  mypb:Paramblockrec;
     err:oserr;
begin
with mypb do
  begin
    iocompletion:=nil;
    ionameptr:=@filename;
    ioVrefnum:=vrefnum;
    iorefnum:=0;{dummy for bad returns}
    ioVersNum:=0;
    IoPermssn:=fsRdPerm;{read only}
    ioMisc:=nil;
  end;{with}
scsi_wait;
err:=PBOpenRF(@mypb,false);
refnum:=mypb.iorefnum;
my_openRF_readonly:=err;
end;{proc}
function setmytype( var mypath:myresPathtype;
                    index:integer;
                    var atype:restype
                    ):boolean;
{set the current type, return true if suceeded}
{eith index (1 to ntypes) or set by type}
label 99,88,77;
var offset:longint;
    ii:integer;
    rlsize:longint;
    bcount:longint;
begin
with mypath do
  begin
  if status<typelistopen then goto 99;
  if index>0 then
     begin
     {pick type by index}
     if index>ntypes then goto 99;
      {**R-}
      current_type:=typelist^^[index-1].thetype;
      offset:=typelist^^[index-1].offset_typelist_to_reflist;
      nrefs:=typelist^^[index-1].count_minus_one+1;
      {**R+}
      atype:=current_type;
      current_type_subscript:=index-1;
     end
   else
     begin
     {pick type by name}
     for ii:=0 to nrefs-1 do
        begin
        {**R-}
          if typelist^^[ii].thetype=atype then
              begin
                 current_type:=typelist^^[ii].thetype;
                 offset:=typelist^^[ii].offset_typelist_to_reflist;
                 nrefs:=typelist^^[ii].count_minus_one+1;
                 current_type_subscript:=ii;
                 goto 77;{match}
              end;
         {**R+}
        end;
      goto 99;{fail}
     end;
  77:
  {load the reference list for this type}
  Hunlock(handle(reflist));
  status:=typelistopen;
  offset:=offset_to_typelist+offset;{compute absolute offset}

  {reserve memory}
  rlsize:=nrefs*12;
  hunlock(handle(reflist));
  sethandlesize(handle(reflist),rlsize);
  if memerror<>noerr then goto 99;

  Hlock(handle(reflist));
  {actually do the read}
   if SetFPos(fileref,fsFromStart,offset)<>noerr then goto 88;
   bcount:=rlsize;
   scsi_wait;
   if FsRead(fileref,bcount,ptr(reflist^))<>noerr then goto 88;
   if bcount<>rlsize then goto 88;
   {we've got the reflist "open"}
   hunlock(handle(reflist));
   status:=reflistopen;
  end;{while}
setmytype:=true;
exit;{normal}
  88:
  Hunlock(handle(mypath.reflist));
  mypath.status:=typelistopen;
  99:
  setmytype:=false;{failure}
end;{setmytype}

Function CopyResData(  var mypath:myresPathtype;
                            var index:integer;
                            var id:integer;
                            var  psize:longint;
                            var  pattr:integer;
                            var  pname:str255 ):boolean;
{copy resource data to handle
 either index(1 to nrefs) or search for id}
 const offsetmask=$00FFFFFF;
       ash=24;
       amask=$000000FF;
label 99,88,77,85;
var offset,noffset:longint;
    ii:integer;
    bcount:longint;
    rdsize:longint;
    noname:boolean;
    nsize:integer;
begin
psize:=0;
pname:='';
pattr:=0;
with mypath do
  begin
  if status<reflistopen then goto 99;
  hlock(handle(reflist));
  if index>0 then
     begin
     {**R-}
      offset:=(reflist^^[index-1].attrib_and_offset) and offsetmask;
      pattr:=((reflist^^[index-1].attrib_and_offset) shr ash) and amask;
      id:=reflist^^[index-1].theid;
      noffset:=reflist^^[index-1].offset_namelist_to_name;
     {**R+}
     end
  else
     begin
     for ii:=0 to ntypes-1 do
       begin
       {**R-}
        if reflist^^[ii].theid=id then
           begin
             offset:=(reflist^^[ii].attrib_and_offset) and offsetmask;
             pattr:=((reflist^^[ii].attrib_and_offset) shr ash) and amask;
             noffset:=reflist^^[ii].offset_namelist_to_name;
             goto 77;
           end;
        {**R+}
       end;{for}
      hunlock(handle(reflist));
       goto 88;{fail}
     77:
     end;
  hunlock(handle(reflist));

  {convert to absolute offsets}
  offset:=offset_to_res_data+offset;
  noname:=(noffset=-1);
  if not noname then noffset:=noffset+offset_to_namelist;

   if not noname then
         begin
         {get name length}
         if SetFPos(fileref,fsFromStart,noffset)<>noerr then goto 88;
         bcount:=2;
         scsi_wait;
         if FsRead(fileref,bcount,@nsize)<>noerr then goto 88;
         if bcount<>2 then goto 88;
         nsize:=(nsize shr 8) and $00FF;{convert first byte to integer}
         nsize:=nsize+1;{length of pascal string}
         {get the whole name}
         {get name length}{use relative positioning}
         scsi_wait;
         if SetFPos(fileref,fsfrommark,-2)<>noerr then goto 88;
         bcount:=nsize;
         scsi_wait;
         if FsRead(fileref,bcount,@pname)<>noerr then goto 88;
         if bcount<>nsize then goto 88;
         end;{if name}

  {get data length}
  scsi_wait;
   if SetFPos(fileref,fsfromstart,offset)<>noerr then goto 88;
   bcount:=4;
   scsi_wait;
   if FsRead(fileref,bcount,@rdsize)<>noerr then goto 88;
   if bcount<>4 then goto 88;

   {allocate space for data}
   hunlock(resdata);
   sethandlesize(resdata,rdsize);
   if memerror<>noerr then goto 99;

   {read in the data}
   {offset:=offset+4;}{read from mark after data length}
   {if SetFPos(fileref,fsfromStart,offset)<>noerr then goto 85;}
   bcount:=rdsize;
   hlock(resdata);
   scsi_wait;
   if FsRead(fileref,bcount,(resdata^))<>noerr then goto 85;
   hunlock(resdata);
   if bcount<>rdsize then goto 85;
   {we have got it}
   psize:=rdsize+4;{add 4 to size to make consistent with
                    result of SIzeResource}

  end;{with}

Hunlock(mypath.resdata);
copyResData:=true;
exit;
{failure}
  85:
  88:
  99:
Hunlock(mypath.resdata);
copyResData:=false;
end;{function}

procedure closepath(var mypath:myresPathtype);
var err:oserr;
begin

if goodhandle(handle(mypath.reflist),'closepath1') then
     Hunlock(handle(mypath.reflist))
else
     sysbeep(1);
if goodhandle(handle(mypath.typelist),'closepath2') then
     Hunlock(handle(mypath.typelist))
else
     sysbeep(1);
if goodhandle(mypath.resdata,'closepath3')then
     Hunlock(handle(mypath.resdata))
else
     sysbeep(1);

if mypath.reflist<>nil then
    sethandlesize(handle(mypath.reflist ),32);
if mypath.typelist<>nil then
    sethandlesize(handle(mypath.typelist ),32);
if mypath.resdata<>nil then
    sethandlesize(handle(mypath.resdata ),32);
if mypath.status>=pathempty then
         begin
        { dbarray[dbaopen]:=dbarray[dbaopen]-1;}
         err:=FSclose(mypath.fileref);
         end;

mypath.status:=pathbad;
end;{proc closepath}

function openpath(var mypath:myresPathtype;pfilename:str255;pvolref:integer):oserr;
label 99,98;
const myerr=-999;
      minimumRFsize=16;
var err,err2:oserr;
    lsize:longint;
    bcount:longint;
    theeof:longint;
begin
err:=myerr;
with mypath do
   begin
      volref:=pvolref;
      filename:=pfilename;
      current_type:='    ';
      ntypes:=0;
      nrefs:=0;
      status:=pathbad;

      {open resource fork}
      err:=my_openRF_readonly(pfilename,pvolref,fileref);
      if err<>noerr then goto 99;
      {dbarray[dbaopen]:=dbarray[dbaopen]+1;}
      status:=pathopen;

      {get Eof to see if this file has a resource fork}
      err:=geteof(fileref,theeof);
      if err<>noerr then goto 99;
      {do a normal exit on an empty resource fork}
      if theeof<minimumRFsize then
            begin
              ntypes:=0;
              nrefs:=0;
              status:=pathempty;
              openpath:=noerr;
              closepath(mypath);
              exit;
           end;



      {get offsets to data and start}
      err:=SetFPos(fileref,fsFromStart,0);
      if err<>noerr then goto 99;
      bcount:=8;
      scsi_wait;
      err:=FsRead(fileref,bcount,@offset_to_res_data);
      if err<>noerr then goto 99;
      if bcount<>8 then goto 98;

      {get resource map}
      err:=SetFPos(fileref,fsFromStart,offset_to_res_map);
      if err<>noerr then goto 99;
      bcount:=sizeof(myresMaptype);
      scsi_wait;
      err:=FsRead(fileref,bcount,@map);
      if err<>noerr then goto 99;
      if bcount<>sizeof(myresMaptype) then goto 98;

      {compute absolute offset to type list,name list}
      offset_to_typelist:=offset_to_res_map+map.offset_map_to_typelist;
      offset_to_namelist:=offset_to_res_map+map.offset_map_to_namelist;

      {get number of types}
      err:=SetFPos(fileref,fsFromStart,offset_to_typelist);
      if err<>noerr then goto 99;
      bcount:=2 {sizeof(myresMaptype)};
      scsi_wait;
      err:=FsRead(fileref,bcount,@ntypes);
      if err<>noerr then goto 99;
      if bcount<>2 {sizeof(myresMaptype)}then goto 98;
      ntypes:=ntypes+1;

      {resize handle for type list}
      lsize:=8*ntypes;
      Hunlock(handle(typelist));
      sethandlesize(handle(typelist),lsize);
      if memerror<>noerr then
          begin
          err:=memerror;
          goto 99;
          end;

      status:=typelistopen;
      hlock(handle(typelist));

      {read type list into handle}
     { err:=SetFPos(fileref,fsfromstart,offset_to_typelist+2);
      if err<>noerr then goto 99;} {read from mark}
      bcount:=lsize;
      scsi_wait;
      err:=FsRead(fileref,bcount,Ptr(typelist^));
      hunlock(handle(typelist));
      if err<>noerr then goto 99;
      if bcount<>lsize then goto 98;

   end;{with mypath}

openpath:=noerr;
exit;{normal exit}
98:err:=myerr;
99:{error exit}
closepath(mypath);
openpath:=err;
end;{proc openpath}



{$S        }
function Mygrowzone(cbneeded:size):longint;
var dontmove:handle;
    result:longint;
begin
  result:=0;
  dontmove:=GZsaveHnd;
  if growzoneguardblock<>nil then
     if growzoneguardblock<>dontmove then
      begin
      result:=GetHandleSize(growzoneguardblock);
      DisposHandle(growzoneguardblock);
      growzoneguardblock:=nil;
      sysbeep(1);
      end;

lowmemoryGZflag:=true;

mygrowzone:=result;
end;{function}
procedure setup_mygrowzone;

begin
lowmemoryGZflag:=false;
growzoneguardblock:=newhandle(GZguardblocksize);
SetGrowZone(@mygrowzone);

end;
procedure low_memory_halt;
{low memory warning - post message in a different way to work better}
var
    wait,endit:longint;
begin
if rinfo<>nil then
  begin
       DisposPtr(ptr(rinfo));
       rinfo:=nil;
   end;
if ainfo<>nil then
  begin
       DisposPtr(ptr(ainfo));
       ainfo:=nil;
   end;
replaceline('Not enough memory to continue safely',errorline);
showstatus;
wait:=120;
delay(wait,endit);
close_all_and_halt(true);
end;

{$S startup}
procedure allocate_big_memory;
const
    safety=150000;{minimum free space}
var needed:size;
    wevegot,grow:size;
begin
needed:=Sizeof(resourceinfoarray)+Sizeof(applinfoarray);
ResrvMem(needed+safety);
Wevegot:=MaxMem(grow);
if wevegot<(needed+safety) then
     begin
       low_memory_halt;
     end
 else
     begin
       rinfo:=resourceinfoarrayptr(NewPtr(needed));
       ainfo:=applinfoarrayptr(NewPtr(needed));
       if (rinfo=nil) or(ainfo=nil) then low_memory_halt;
     end;

end;

procedure add_safekey(ss:str255);
var i:integer;
begin
uprString(ss,true);{upper case}
if safekeywords_count<maxsafekeywords then
   begin
     for i:=1 to safekeywords_count do
        begin
          if safekeywords[i]=ss then exit;{already in the list}
        end;
     safekeywords_count:=safekeywords_count+1;
     safekeywords[safekeywords_count]:=ss;
   end;
end;{procedure}

procedure write_safekeys;
var i:integer;
begin
if not outputopen then exit;
 for i:=1 to safekeywords_count do
   begin
   scsi_wait;
   writeln(outfile,safekeywords[i]);
   end;
   write_end_flag('end safe names');

end;

procedure read_safekeys;
{read list of safe keyword file exclusions}
var line:str255;
    tokens:tokenstype;
    ntokens:integer;
begin
if not inputopen then exit;
line:='';
while not eof(infile) do
   begin
   read_input(line);
   if test_end_flag(line) then exit;
   tabscan(line,tokens,ntokens);
   if ntokens>=1 then add_safekey(tokens[1]);
    end;
end;

procedure write_morechecks;
{write list of additional (boot block?) checksums
 shell procedure for future expansion}
var i:integer;
begin
if not outputopen then exit;
  (* write it here *)
   write_end_flag('end morechecks');
end;

procedure read_morechecks;
{read list of additional (boot block?) checksums
 shell procedure for future expansion}
var line:str255;
    tokens:tokenstype;
    ntokens:integer;
begin
if not inputopen then exit;
line:='';
while not eof(infile) do
   begin
   read_input(line);
   if test_end_flag(line) then exit;
    (* process here *)
    end;
end;

{$S core}
function filenamesafetylevel(name:str255):safetype;
{checksum all resources above this level}
label 99;
var i:integer;
    result:safetype;
begin
uprString(name,true);{upper case}
 for i:=1 to safekeywords_count do
   begin
   if Pos(safekeywords[i],name)<>0 then
      begin
         result:=unknown;
         goto 99;
      end;
   end;
result:=safe;
99:
{poststatus(safetynames[result],errorline);}
filenamesafetylevel:=result;
end;

{$S startup}
procedure start_safekey;
{Make list of substrings in file names that
 indicate the file is a temporary file or settings file
 that frequently changes and may contain
 but "unknown" resource types that are really safe}
begin
safekeywords_count:=0;
add_safekey('Scrapbook');
add_safekey('Clipboard');
add_safekey('TEMP');
add_safekey('WORK');
add_safekey('SETTING');
add_safekey('RESUME');
add_safekey('PREFER');
add_safekey('OPTION');
add_safekey('SCRATCH');
end;
{$S startup}
FUNCTION HFSExists: BOOLEAN;
 {From Tech note #77}
 var w:wordptr;
Begin {HFSExists}
  w:=WordPtr(Pointer(FSFCBLen));
        HFSExists := (w^) > 0;
End;  {HFSExists}

procedure HFSWarning;
{Quit if HFS not available}
var wait,endit:longint;
begin
if not HFSexists then
    begin
    wait:=180;
    Poststatus('This program requires the HFS file system',errorline);
    delay(wait,endit);
    doevent(false);
    close_all_and_halt(true);
    end;
end; {HFSWarning}

FUNCTION GetRealBootDrive: INTEGER;
 {From Tech Note #77}
    VAR
         MyHPB         : HParamBlockRec;
         MyWDPB        : WDPBRec;
         err         : OSErr;
   w:wordptr;
        sysVRef    : integer; {will be the vRefNum of open system’s vol}

    Begin {GetRealBootDrive}
            if HFSExists then Begin        {If we’re running under HFS... }

            {get the VRefNum of the volume that }
            {contains the open System File      }
    w:=WordPtr(Pointer(SysMap));
            err:= GetVRefNum(w^,sysVRef);

            with MyHPB do Begin
            {Get the “System” vRefNum and “Blessed” dirID}
                            ioNamePtr   := NIL;
                            ioVRefNum   := sysVRef; {from the GetVrefNum call}
                            ioVolIndex  := 0;
                    End; {with}
                    err := PBHGetVInfo(@MyHPB, FALSE);


                   with myWDPB do Begin      {Open a working directory there}
                            ioNamePtr   := NIL;
                            ioVRefNum   := sysVRef;
                       ioWDProcID  := SysWDProcID; {Using the system proc ID}
                            ioWDDirID   := myHPB.ioVFndrInfo[1];{ see TechNote 67}
                    End; {with}
            err := PBOpenWD(@myWDPB, FALSE);

                    GetRealBootDrive := myWDPB.ioVRefNum;
            {We’ve got the real WD}
            End Else {we’re running MFS}
                 begin
                 w:=WordPtr(Pointer(BootDrive));
                    GetRealBootDrive := w^;
                 end;
            {BootDrive is valid under MFS}
End;  {GetRealBootDrive}

{$S core}
procedure tabscan{(line:str255; var tokens:tokenstype;var ntokens:integer)};
{Input scanner: breaks a line into tokens separated by tabs}
{Trims leading and trailing blanks}
label 99,88;
var tab,sp:char;
    i,j,next,last:integer;
begin
tab:=chr(9);
sp:=' ';

for i:=1 to maxtokens do tokens[i]:='';

ntokens:=0;
next:=1;
last:=length(line);
while(next<=last) do
    begin
    {skip leading blanks}
    while(line[next]=sp) do
        begin
           next:=next+1;
           if(next>last) then goto 99;
        end;{while not space}

    {copy up to tab or end of line}
    ntokens:=ntokens+1;
    while(line[next]<>tab) do
        begin
           tokens[ntokens]:=concat(tokens[ntokens],line[next]);
           next:=next+1;
           if(next>last)then goto 99;
        end;{while not tab}
    next:=next+1;{skip tab}
    end;{while}
99:
{remove trailing spaces}
for i:=1 to ntokens do
  begin
     last:=length(tokens[i]);
     for j:=length(tokens[i]) downto 1 do
        begin
        if tokens[i][j]<>sp then
            begin
               last:=j;
               goto 88;
            end;
        end;
     88:
       if last>0 then
             tokens[i]:=copy(tokens[i],1,last)
          else
             tokens[i]:='';
  end;{for i}
end;{proc}


function find_type(atype:restype):integer;
{find a resource type if it exists.  Return the current supscript or zero
if it does not exist}
{binary search}
var low,high,mid:integer;
begin
low:=1;
high:=rtypes_count;
   while low<=high do
     begin
       mid:=(low+high) div 2;
       if atype=rtypes[mid].thetype then
           begin
             find_type:=mid;
              exit;
           end
        else if atype>rtypes[mid].thetype then
           begin
             low:=mid+1;
           end
        else
           begin
              high:=mid-1;
           end;
      end;{while}
find_type:=0;{no match}
end;{function}

function find_and_add_type(atype:restype;howsafe:safetype):integer;
{find a resource type if it exists, otherwise add it to rtypes in sorted
 order.  Return the current supscript}
{binary search and insertion}
var low,high,mid,ii,at:integer;
     ss:str255;
begin
low:=1;
high:=rtypes_count;
at:=low;
   while low<=high do
     begin
       mid:=(low+high) div 2;
       if atype=rtypes[mid].thetype then
           begin
             find_and_add_type:=mid;
              exit;
           end
        else if atype>rtypes[mid].thetype then
           begin
             low:=mid+1;
             at:=mid+1;
           end
        else  {atype<rtypes[mid].thetype}
           begin
              high:=mid-1;
              at:=mid;
           end;

      end;{while}

if rtypes_count>=maxtype then
     begin
       poststatus('My maximum resource type count exceeded',errorline);
       find_and_add_type:=0;
       exit;
    end;
for ii:=rtypes_count downto at do
    begin
    rtypes[ii+1]:=rtypes[ii]
    end;
rtypes[at].thetype:=atype;
rtypes[at].safety:=howsafe;
rtypes[at].occurs:=0;
{wait_for_buttons(concat(atype,safetynames[howsafe],continuebut));}

rtypes_count:=rtypes_count+1;
find_and_add_type:=at;
end;{function}

function find_type_old(atype:restype):integer;
{old version}
label 99;
var i:integer;
    result:integer;
begin
result:=0;
  for i:=1 to rtypes_count do
     begin
       with rtypes[i] do
          begin
            if thetype=atype then
               begin
                  result:=i;
                  goto 99;
               end;
          end;
     end;
99:
find_type_old:=result;

end;{find_type}

procedure add_type(atype:restype;howsafe:safetype);
{add a type and it's classification to the list in memory
if it does not already exist}
var ignore:integer;
begin
ignore:=find_and_add_type(atype,howsafe);
end;

procedure add_type_old(atype:restype;howsafe:safetype);
var i,result:integer;
{add type to tables if it does not already exist}
{old version}
begin
if find_type(atype)=0 then
    begin
    if rtypes_count<maxtype then
        begin
         rtypes_count:=rtypes_count+1;
         with rtypes[rtypes_count] do
           begin
              thetype:=atype;
              safety:=howsafe;
              occurs:=0;
           end ;{with}
           sorttypes(rtypes,rtypes_count);
         end
     else
         begin
           poststatus('My maximum resource type count exceeded',errorline);
         end;

     end;

end;{add_type}

{$S appl}
procedure detail_appl_check;
{Compare the checksums in memory with the old checksums on file for applications}
{This assumes both are sorted by creator,creationdate,filename,dirid}
{if no checksums were done before, just compare sizes}

type statetype=(oldgreater,newgreater,
               checkequality,sizeequality,
               sameappl,sameapplbadsize,sameapplbadcheck);
var
    jnew:integer;
    jcreator:ostype;
    jcreatorstart:integer;
    jcreatorend:integer;
    state:statetype;
    oldfile,newfile:myfilenametype;
    filecomp:integer;
    oldcreator,newcreator:OStype;
    oldcreationdate,newcreationdate:longint;
    oldsize,newsize:longint;
    oldunsafecount,newunsafecount:longint;
    oldchecksize,newchecksize:longint;
    oldchecksum,newchecksum:integer;
    olddirid,newdirid:longint;
    oldvol,newvol:integer;
    newhidden:boolean;
    end_on_old,end_on_new:boolean;
    oid,nid:str255;

procedure get_next_old;
label 22;{repeat}
var line:str255;
    tokens:tokenstype;
    ntokens:integer;
    work:longint;
begin
22:
ntokens:=0;
repeat
if end_on_old then exit;
if eof(infile) then
    begin
      end_on_old:=true;
      exit;
    end;
read_input(line);
{treat "*****" as end}
if test_end_flag(line) then
    begin
      end_on_old:=true;
      exit;
    end;
tabscan(line,tokens,ntokens)

until(ntokens>=9);{ignore short/blank lines}

{breakdown line as:}
{creator <tab> creationdate <tab> filename <tab> dirid <tab> volume
<tab> thesize <tab> unsafecount <tab> checksize <tab> checksum}

filltype(oldcreator,tokens[1]);{blank fill type}
stringtonum(tokens[2],oldcreationdate);
oldfile:=tokens[3];
stringtonum(tokens[4],olddirid);
stringtonum(tokens[5],work);
oldvol:=work;
stringtonum(tokens[6],oldsize);
stringtonum(tokens[7],work);
oldunsafecount:=work;
stringtonum(tokens[8],oldchecksize);
stringtonum(tokens[9],work);
oldchecksum:=work;
{additional stuff at end of line will be ignored}
{skip non-matching volumes}
if oldvol<>0 then
   if oldvols[oldvol].matchto=0 then goto 22;
end;{get_next_old}

procedure get_next_new;
label 88,22;
var jj:integer;
begin
22:
jnew:=jnew+1;
if jnew>acount then
    begin
      end_on_new:=true;
      exit;
    end;
    (*
          {info on applications}
      applinforec=record
                  thesize:longint;
                  creator:OStype;
                  creationdate:longint;
                  dirid:longint;
                  filename:myfilenametype;
                  unsafecount:integer;
                  checksum:integer;
                  checksize:longint;
                  flags:integer;
                  end;

    *)
with  ainfo^[jnew] do
   begin
     newcreator:=creator;
     newcreationdate:=creationdate;
     newfile:=filename;
     newsize:=thesize;
     newunsafecount:=unsafecount;
     newchecksize:=checksize;
     newchecksum:=checksum;
     newdirid:=dirid;
     {matching old volume if any}
     if (flags and applvolumemask)=0 then
              begin
              newvol:=0
              end
     else
              begin
              newvol:=newvols[(flags and applvolumemask)].matchto;
              {skip non-matching volumes}
              if newvol=0 then goto 22;
              end;

     newhidden:=(flags and applinvisiblemask)<>0;
   end;{with}

{find last occurance of current signature}
if newcreator<>jcreator then
    begin
    jcreator:=newcreator;
    jcreatorstart:=jnew;
    for jj:=jnew+1 to acount do
       if ainfo^[jj].creator<>jcreator then
         begin
           jcreatorend:=jj-1;
           goto 88;
         end;
     jcreatorend:=acount;
     88:
    end;

end;{get_next_new}

procedure was_renamed_or_moved;
label 88;
{one to many check for current signature}
{call this if no match and there is more than one occurance}
{this assumes that an application is OK regardless of name and
 directory changes if other features match:
        creationdate
        checksize
        checksum
        unsafecount

        or if (oldunsafecount=notcounted)
           creationdate
           thesize}
var
    jj:integer;
begin
for jj:=jcreatorstart to jcreatorend do
    with ainfo^[jj] do
    begin
      if creationdate=oldcreationdate then
          if (oldunsafecount=notcounted) or (fastapplcheck) then
             begin
             if (oldsize=thesize) then
                  begin
                  flags:=flags or applrenamemask;
                  end
             end
          else
             begin
             if oldunsafecount=unsafecount then
               if oldchecksize=checksize then
                 if oldchecksum=checksum then;
                 begin
                  flags:=flags or applrenamemask;
                 end;
             end;
    end;
end;{was_moved_or_renamed}

begin{detail_resource_check}
jcreator:='$$$$';
if not inputopen then exit;
jnew:=0;
end_on_old:=false;
end_on_new:=false;
get_next_old;
get_next_new;
while not(end_on_old or end_on_new) do
  begin
  {debug info}
  (*
  poststatus(concat(concat(oldfile,':'),newfile),byline);
  poststatus(concat(concat(oldcreator,':'),newcreator),byline+1);
  numtostring(oldcreationdate,oid);
  numtostring(newcreationdate,nid);
  poststatus(concat(concat(oid,':'),nid),byline+2);
  numtostring(olddirid,oid);
  numtostring(newdirid,nid);
  poststatus(concat(concat(oid,':'),nid),byline+3);
  *)
  state:=newgreater;

  {if creator signature matches, check for rename/move on partial match}
  if oldcreator=newcreator then
     begin
       if oldcreationdate=newcreationdate then
           begin
          {wait_for_buttons('creation match',continuebut);}
           filecomp:=filenamecompare(oldfile,newfile);
           if filecomp=0{equal} then
              begin
               {wait_for_buttons('filename match',continuebut);}
              if oldvol=newvol then
                begin
                  if olddirid=newdirid then
                     begin
                     {wait_for_buttons('dir match',continuebut);}
                        {this is the same file name in the same directory}
                        state:=sameappl;
                        {now check for changed vs exact match}
                       {match on
                        checksize
                        checksum
                        unsafecount

                        or if oldunsafecount=notcounted
                           thesize}

                        if (oldunsafecount=notcounted) or (fastapplcheck) then
                           begin
                           if (oldsize=newsize) or newhidden then
                              {less stringent check on non-application
                               hidden files - Desktop changes size}
                              state:=sizeequality;
                           end
                        else
                           begin
                           if oldchecksize=newchecksize then
                           if oldchecksum=newchecksum then
                           if oldunsafecount=newunsafecount then
                              state:=checkequality;
                           end;

                     end{=dir}
                  else
                     begin
                     if olddirid>newdirid then
                         begin
                         state:=oldgreater;
                         end;
                     was_renamed_or_moved;
                     end{<>dir}
                end{=vol}
              else
                 begin
                     if oldvol>newvol then
                         begin
                         state:=oldgreater;
                         end;
                     was_renamed_or_moved;
                 end{<>vol}
              end{=file}
           else
              begin
              if filecomp>0{oldfile>newfile} then
                 begin
                   state:=oldgreater;
                 end;
                 was_renamed_or_moved;
              end{<>file}

           end{=creation date}
       else
           begin
           if oldcreationdate>newcreationdate then
              begin
                 state:=oldgreater;
              end;
              was_renamed_or_moved;
           end{<>creation date}

     end{= creator}
  else if oldcreator>newcreator then
      begin
         state:=oldgreater;
      end;


   {end of compares}
    case state of
    sizeequality:
                 begin
                 {equality on the basis of size - fast check}
                 ainfo^[jnew].flags:=ainfo^[jnew].flags or applexactmatchmask;
                 get_next_old;
                 get_next_new;
                 {wait_for_buttons('equal appl',continuebut);}
                 if fastapplcheck and (oldunsafecount<>notcounted) then
                      begin
                         {copy old checksums etc.
                          for future reference so that info
                          is not lost by writing output from
                          a short check}
                         with ainfo^[jnew] do
                           begin
                           checksum:=oldchecksum;
                           unsafecount:=oldunsafecount;
                           checksize:=oldchecksize;
                           end;
                      end;
               end;
    checkequality:  begin
                 {equality on the basis of all checksums - full check}
                 ainfo^[jnew].flags:=ainfo^[jnew].flags or applexactmatchmask;
                 get_next_old;
                 get_next_new;
                 {wait_for_buttons('equal appl',continuebut);}
               end;
    sameappl:   begin
                 ainfo^[jnew].flags:=ainfo^[jnew].flags or applchangedmask;
                  {wait_for_buttons('same appl no match',continuebut);}
                get_next_old;
                get_next_new;
               end;
    sameapplbadsize:   begin
                 ainfo^[jnew].flags:=ainfo^[jnew].flags or applchangedmask;
                 ainfo^[jnew].flags:=ainfo^[jnew].flags or applbadsizemask;
                  {wait_for_buttons('same appl no match',continuebut);}
                get_next_old;
                get_next_new;
               end;
    sameapplbadcheck:   begin
                 ainfo^[jnew].flags:=ainfo^[jnew].flags or applchangedmask;
                 ainfo^[jnew].flags:=ainfo^[jnew].flags or applbadcheckmask;
                  {wait_for_buttons('same appl no match',continuebut);}
                get_next_old;
                get_next_new;
               end;
    oldgreater:begin
                 {wait_for_buttons('old greater',continuebut);}
                 get_next_new;
               end;
    newgreater:begin
                 {wait_for_buttons('new greater',continuebut);}
                 get_next_old;
               end;
    end;{case of state}

  end;{while not done}

end;
procedure show_APPL_detail_changes;
{On Screen Summary of Application Changes}
label 77;
const
    chlimit=10;
var
    j:integer;
    charray:array[1..chlimit] of integer;
    ch,chcount:integer;
    filename,dname:str255;
    work:str255;
    jtype:integer;
    dd:longint;
    newappl:longint;
    moveorrenamedappl:longint;
    changedappl:longint;
    dangerappl:longint;
    ans_show,notify:boolean;
    hidden:boolean;
    vnum:integer;
procedure show_change(mess:str255);
begin
folder_name(dd,dname);
clear_to_end(fileline);
PostStatus(newvols[vnum].vname,fileline);
work:= concat(concat(dname,':'),filename);
poststatus(work,fileline+1);

wait_for_buttons(mess,continuebut);
clear_to_end(fileline);
end;

procedure mark_change(jj:integer);
begin
notify:=true;
{keep pointers to the first few changes to speed up display}
if chcount<chlimit then
      begin
       chcount:=chcount+1;
       charray[chcount]:=jj;
      end;
end;

begin
chcount:=0;
{skip this all if there was no input file}
if not inputopen then exit;
{count changes}
newappl:=0;
moveorrenamedappl:=0;
changedappl:=0;
dangerappl:=0;
notify:=false;
for j:=1 to acount do
  begin
  {only flag changes to stuff on matched volumes}
  if newvols[(ainfo^[j].flags and applvolumemask)].matchto<>0 then
    begin
       if (ainfo^[j].flags and applexactmatchmask)<>applexactmatchmask then
         if (ainfo^[j].flags and applrenamemask)=applrenamemask then
            begin
               {moved or renamed or duplicated}
               moveorrenamedappl:=moveorrenamedappl+1;
               mark_change(j);
            end
         else
            begin
              if (ainfo^[j].flags and applchangedmask)=applchangedmask then
                begin
                  {changed}
                  changedappl:=changedappl+1;
                  mark_change(j);
                end
              else
                begin
                   {"new"}
                    newappl:=newappl+1;
                    mark_change(j);

                end
            end;
     end;
     if (ainfo^[j].flags and appldangermask)=appldangermask then
         begin
         dangerappl:=dangerappl+1;
         mark_change(j);
         end;
  end;{for}
 {quick skip to end}
if chcount<chlimit then
     begin
     chcount:=chcount+1;
     charray[chcount]:=acount+1;
     end;

{exit if no changes}
if not notify then exit;

{notify of changes and give a chance to see the changes on screen and on disk}
sysbeep(1);
clear_to_end(askline-3);
poststatus('',askline-4);
numtostring(newappl,work);
work:=concat('New: ',work);
poststatus(work,askline-4);
numtostring(moveorrenamedappl,work);
work:=concat('Renamed/Moved: ',work);
poststatus(work,askline-3);
numtostring(changedappl,work);
work:=concat('Changed: ',work);
poststatus(work,askline-2);

if Dangerappl<>0 then
begin
numtostring(dangerappl,work);
work:=concat('Dangerous: ',work);
poststatus(work,askline-1);
end;

work:=
'These are differences in the applications/hiddenfiles.  Do you want to see the details on screen?';
ans_show:=ask(work,nodefaultbut);
clear_to_end(askline-4);

if not outputopen then
   if ask('Do you want to write a new summary output file?',nodefaultbut) then
      begin
       open_output;
      end;

if not ans_show then exit;
poststatus('List differences in applications or hidden files:',pathline);
{loop to show individual changes}
j:=0;
ch:=0;
while(j<=acount)do
  begin
  {faster skip to marked changes}
  if ch<chcount then
     begin
       ch:=ch+1;
       j:=charray[ch];
     end
  else
     begin
       j:=j+1;
     end;
    if j>acount then goto 77;

    filename:=ainfo^[j].filename;
    dd:=ainfo^[j].dirid;
    vnum:=ainfo^[j].flags and applvolumemask;
    hidden:=(ainfo^[j].flags and applinvisiblemask)<>0;
    if newvols[(ainfo^[j].flags and applvolumemask)].matchto<>0 then
        begin
        if (ainfo^[j].flags and applexactmatchmask)<>applexactmatchmask then
          if (ainfo^[j].flags and applrenamemask)=applrenamemask then
             begin
                {moved or renamed or duplicated}
                Show_change('was moved, renamed or duplicated')
             end
          else
             begin
               if (ainfo^[j].flags and applchangedmask)=applchangedmask then
                 begin
                   {changed}
                   if hidden then
                     Show_change('Changed Invisible File')
                   else
                     Show_change('Changed Application');
                 end
               else
                 begin
                   if hidden then
                     Show_change('New Invisible File')
                   else
                     Show_change('New Application');
                 end
             end;
        end;
   if (ainfo^[j].flags and appldangermask)=appldangermask then
       begin
       Show_change('Infected with a dangerous resource type');
       end;
  end;{for}
77:
clear_to_end(pathline);
end;{proc show_APPL_detail_changes}

{$S detail}
procedure detail_resource_check;
{Compare the checksums in memory with the old checksums on file}
{This assumes both are sorted by filename,type,id}
{If there is more than one entry per id the old file is
 assumed sorted by filename,type,id,size,name and checksum.
 This is to allow a old checksum file valid for two system
 versions to be constructed, but this feature is not fully
 supported}

type statetype=(oldgreater,newgreater,equality,sameid);
var
    jnew:integer;
    state:statetype;
    oldtype,newtype:restype;
    oldfile,newfile:myfilenametype;
    oldid,newid:integer;
    oldsize,newsize:longint;
    oldchecksum,newchecksum:integer;
    oldname,newname:string[10];
    end_on_old,end_on_new:boolean;
    oid,nid:str255;
    filecomp:integer;

procedure get_next_old;
var line:str255;
    tokens:tokenstype;
    ntokens:integer;
    work:longint;
begin
ntokens:=0;
repeat
if end_on_old then exit;
if eof(infile) then
    begin
      end_on_old:=true;
      exit;
    end;
read_input(line);
{treat "*****" as end}
if test_end_flag(line) then
    begin
      end_on_old:=true;
      exit;
    end;
tabscan(line,tokens,ntokens)

until(ntokens>=6);{ignore short/blank lines}

{breakdown line as:}
{type <tab> id <tab> size <tab> checksum <tab> name <tab> filename}
filltype(oldtype,tokens[1]);{blank fill type}
stringtonum(tokens[2],work);
oldid:=work;
stringtonum(tokens[3],oldsize);
stringtonum(tokens[4],work);
oldchecksum:=work;
oldname:=tokens[5];
oldfile:=tokens[6];
{additional stuff at end of line will be ignored}

end;{get_next_old}

procedure get_next_new;

begin
jnew:=jnew+1;
if jnew>rcount then
    begin
      end_on_new:=true;
      exit;
    end;
with  rinfo^[jnew] do
   begin
     newtype:=thetype;
     newfile:=sysfiles[(filenameindex and fnamemask)];
     newid:=theid;
     newsize:=thesize;
     newchecksum:=checksum;
     newname:=thename;
   end;

end;{get_next_new}

begin{detail_resource_check}
if not inputopen then exit;
poststatus('Compare System Folder Resources',fileline);
jnew:=0;
end_on_old:=false;
end_on_new:=false;
get_next_old;
get_next_new;
while not(end_on_old or end_on_new) do
  begin
  {debug info}
 (* poststatus(concat(concat(oldfile,':'),newfile),pathline);
  poststatus(concat(concat(oldtype,':'),newtype),pathline+1);
  numtostring(oldid,oid);
  numtostring(newid,nid);
  poststatus(concat(concat(oid,':'),nid),pathline+2);*)
  state:=newgreater;
  filecomp:=filenamecompare(oldfile,newfile);
  if filecomp=0{oldfile=newfile} then
    begin
    if oldtype=newtype then
      begin
      if oldid=newid then
        begin

        {---mark new as id level match---
         since id's are unique this can be used to distingush
         added resources from changed resources}

        state:=sameid;
        rinfo^[jnew].filenameindex:=(rinfo^[jnew].filenameindex or idmatchmask);

        if oldsize=newsize then
          begin
          if oldname=newname then
            begin
            if oldchecksum=newchecksum then
              begin

              {---mark exact equality---}

              state:=equality;
              rinfo^[jnew].filenameindex:=(rinfo^[jnew].filenameindex or exactmatchmask);

              end{checksum equal}
            end{name equal}
          end{size equal}
        end{id equal}

      else if oldid>newid then
        state:=oldgreater;
      end{type equal}

    else if oldtype>newtype then
      state:=oldgreater;
    end{file equal}

  else if filecomp>0{oldfile>newfile} then
    state:=oldgreater;

   {end of compares}
    case state of
    equality:  begin
                 get_next_old;
                 get_next_new;
               end;
    sameid:    begin
                 {in case the old file has multiple entries for the same id}
                 { wait_for_buttons('same id no match',continuebut);}
                get_next_old;
               end;
    oldgreater:begin
                 {wait_for_buttons('old greater',continuebut);}
                 get_next_new;
               end;
    newgreater:begin
                 {wait_for_buttons('new greater',continuebut);}
                 get_next_old;
               end;
    end;{case of state}

  end;{while not done}

end;
procedure show_detail_changes;
{On Screen Summary of Changes}
{this will show added or changed resources but not
 deleted resources}
var jres:integer;
    new:boolean;
    filename:str255;
    safename:str255;
    id,work,name:str255;
    jtype:integer;
    neworchanged:longint;
    norc:str255;
    ans_show:boolean;
procedure show_change(mess:str255);
begin
clear_to_end(fileline);
work:= concat('File: ',filename);
poststatus(work,fileline);
work:=concat(concat('Type:',rinfo^[jres].thetype),' (');
work:=concat(concat(concat(work,safename),') Id:'),id);
name:=rinfo^[jres].thename;
if name<>'' then
    begin
        work:=concat(concat(work,' Name:'),name);
    end;
poststatus(work,errorline);
wait_for_buttons(mess,continuebut);
clear_to_end(fileline);
end;
begin
{skip this all if there was no input file}
if not inputopen then exit;
{count changes}
neworchanged:=0;
for jres:=1 to rcount do
  begin
    if (rinfo^[jres].filenameindex and exactmatchmask)<>exactmatchmask then
      neworchanged:=neworchanged+1;
  end;{for}

{exit if no changes}
if neworchanged=0 then exit;

{notify of changes and give a chance to see the changes on screen and on disk}
sysbeep(1);
numtostring(neworchanged,norc);
norc:=concat(concat('There are ',norc),
' new or changed resources in the system folder.  Do you want to see the details on screen?');
ans_show:=ask(norc,nodefaultbut);

if not outputopen then
   if ask('Do you want to write a new summary output file?',nodefaultbut) then
      begin
       open_output;
        if writeoutputflag and fastapplcheck then
        fastapplcheck:=not Ask('Do you want a full checksum of applications',yesbut);
      end;

if not ans_show then exit;

{loop to show individual changes}
for jres:=1 to rcount do
  begin

    {test flag to see if exact match}
    if (rinfo^[jres].filenameindex and exactmatchmask)<>exactmatchmask then
       begin
         {test flag to see if new or changed}
         new:=not ((rinfo^[jres].filenameindex and idmatchmask)=idmatchmask);
         filename:=sysfiles[(rinfo^[jres].filenameindex and fnamemask)];
         {name for safety level of type}
         jtype:=find_type(rinfo^[jres].thetype);
         if jtype=0 then
            safename:=safetynames[Unknown]
         else
            begin
               safename:=safetynames[rtypes[jtype].safety];
            end;
         numtostring(rinfo^[jres].theid,id);
         if new then
              show_change('This resource is new')
          else
              show_change('This resource is changed');
       end
     else
       if rtypes[find_type(rinfo^[jres].thetype)].safety=dangerous then
         begin
           show_change('This is a dangerous resource type associated with viruses');
         end;
  end;{for}


end;{proc show_detail_changes}
{$S startup}
procedure start_types;
{set up table of some resource types to allow starting without an
input file and for testing}
{See Inside Mac Volume V resource manager for a listing
 of many types}
begin
rtypes_count:=0;
safetynames[Safe]:='Safe';
safetynames[Unsafe]:='Unsafe';
safetynames[Unknown]:='Unknown';
safetynames[Dangerous]:='Dangerous';
{resource types associated with known viruses}
add_type('nVIR',Dangerous);
{Some RESOURCE TYPES KNOWN TO CONTAIN EXECUTABLE CODE}
{also include types that occur sometimes in known viruses,sometimes
 in normal use}
add_type('CODE',unsafe);
add_type('INIT',unsafe);
add_type('ROvr',unsafe);
add_type('ROv#',unsafe);
add_type('PTCH',unsafe);
add_type('PACK',unsafe);
add_type('PDEF',unsafe);
add_type('ADBS',unsafe);
add_type('CACH',unsafe);
add_type('CDEF',unsafe);
add_type('cdev',unsafe);
add_type('DRVR',unsafe);
add_type('FKEY',unsafe);
add_type('FMTR',unsafe);
add_type('KCHR',unsafe);
add_type('LDEF',unsafe);
add_type('MBDF',unsafe);
add_type('MDEF',unsafe);
add_type('MMAP',unsafe);
add_type('SERD',unsafe);
add_type('WDEF',unsafe);
add_type('boot',unsafe);
add_type('insc',unsafe);
add_type('XCMD',unsafe);
add_type('XFNC',unsafe);
add_type('atpl',unsafe);{used by the "scores" virus}
add_type('DATA',unsafe);{used by the "scores" virus}
{RESOURCE TYPES KNOWN NOT TO CONTAIN EXECUTABLE CODE}
add_type('FONT',safe);
add_type('ALRT',safe);
add_type('BNSL',safe);
add_type('DITL',safe);
add_type('DLOG',safe);
add_type('FOND',safe);
add_type('FONT',safe);
add_type('ICN#',safe);
add_type('ICON',safe);
add_type('MENU',safe);
add_type('PAT ',safe);
add_type('PAT#',safe);
add_type('PICT',safe);
add_type('PREC',safe);
add_type('SIZE',safe);
add_type('STR ',safe);
add_type('STR#',safe);
add_type('TEXT',safe);
add_type('LAYO',safe);{desktop layout}
add_type('PAPA',safe);{chooser setting}
add_type('PREF',safe);{print monitor preferences}
add_type('CNTL',safe);
add_type('CURS',safe);
add_type('NFNT',safe);
add_type('fndr',safe);
add_type('itl0',safe);{date/time formats no code hooks}
add_type('scrn',safe);{control panel screen settings}
add_type('BMLS',safe);{appleshare server settings in Appleshare Prep}
add_type('clut',safe);
add_type('clst',safe);
add_type('mach',safe);
add_type('nrct',safe);

{add_type('',safe);}
end;
{$S event}
procedure setdefaultbutton(value:integer);
{set default button for pauses, questions and force updates}
var rr:rect;
begin
setport(mainwindow);
if defaultbutton<>0 then
    begin
      rr:=buttonrects[defaultbutton];
      insetrect(rr,-5,-5);
      Invalrect(rr);
    end;
defaultbutton:=value;
if defaultbutton<>0 then
    begin
      rr:=buttonrects[defaultbutton];
      insetrect(rr,-5,-5);
      Invalrect(rr);
    end;
end;

procedure wait_for_buttons{(ss:str255;default:integer)};
{Wait, display message, and give a chance to:
    "continue", "halt" or "shutdown"}
begin
setdefaultbutton(default);
askanswered:=false;
HiLiteControl(buttons[continuebut],0);{active}
PostStatus(ss,AskLine);
repeat
doEvent(true);
until askanswered;
setdefaultbutton(nodefaultbut);
clear_to_end(askline);
HiLiteControl(buttons[continuebut],255);{inactive}
doevent(false);
end;
procedure wait_for_start(ss:str255;waitsecs:integer);
{wait, display message and startup buttons:
    "ShortCheck", "FullCheck", "SkipIt" "Shutdown"}
    {if a certian time has elapsed, continue}
var default:integer;
    wait,waituntil:longint;
    tag:str255;
begin
default:=startupdefaultbutton;;
wait:=waitsecs*60;
numtostring(waitsecs,tag);
tag:=concat(concat('  (Auto start after ',tag), ' sec)');
setdefaultbutton(default);
{askanswered:=false;}{set in initialize instead}
HiLiteControl(buttons[continuebut],0);{active}
{poststatus(tag,errorline);}
ss:=concat(ss,tag);
PostStatus(ss,AskLine);
doevent(false);
waituntil:=wait+tickcount;
repeat
doEvent(true);
until ((askanswered) or (tickcount>waituntil));
setdefaultbutton(nodefaultbut);
clear_to_end(errorline);
FlushEvents(MDownMask,0);
HiLiteControl(buttons[continuebut],255);{inactive}
doevent(false);
end;

{$S startup}
procedure mySFold(      Var filevar     : text;
                        prompt          :str255;
                        var filepara    :str255;
                        var cancel:boolean);
{
  Do a Standard file open dialog to open an existing TEXT file
  as a TURBO PASCAL text file.
 Use the toolbox to get the file name and set the default vol/folder.
 Use Reset to do the actual open for Turbo.
 This may work only on the 128k ROMS
}
var
   topleft,center    :point;
   ShowTypes  : SFTypeList;
   NTypes     :integer ;
   theErr     :OSErr;
   Reply      :SFreply;
   filename   :string[63];
   ScrHres,ScrVres : integer;
   vol        : integer;
   vserr       :OSerr;


begin
  filepara:='';
  with center do
  begin
  with screenbits.bounds do
    begin
      v:=(top+bottom) div 2;
      h:=(left+right) div 2;
    end;
  end;

  topleft.h:=center.h-170; {position of topleft}
  topleft.v:=center.v-120;

  ShowTypes[0]:='TEXT';
  Ntypes:=1;
  Cancel:=false;
  SFGetFile(topleft,prompt,nil,NTypes,ShowTypes,nil,Reply);
  if Reply.good then
      begin

       vol:=reply.vrefnum;
       filename:=reply.fname;
       vserr:=SetVol(nil,vol); {change default volume}

       {SFGetFile does not do an actual open : FSOpen or PBOpen
        are called to do this in the examples I have seen}

        reset(filevar,filename); {do turbo open}
        filepara:=filename;
      end
  else
      begin
      {may be a cancel or other error}
      Cancel:=true;

      end;

end; {of proc MySFold }

procedure mySFnew(      Var filevar : text;
                        prompt      :str255;
                        orgname     :str255;
                        Creator     :OStype;
                        var cancel:boolean);
{
  Do a Standard file put dialog to open a new TEXT file as a TURBO PASCAL
  text file for output.
  Use the toolbox to get the file name and set the default vol/folder.
  The use Rewrite to do the actual open for Turbo.
  This may work only on the 128k ROMS.
}
var
   topleft,center    :point;
   theErr     :OSErr;
   Reply      :SFreply;
   filename   :string[63];
   ScrHres,ScrVres : integer;
   vol        :integer;
   vserr       :OSerr;
   finderinfo  :finfo;

begin
  with center do
  begin
  with screenbits.bounds do
    begin
      v:=(top+bottom) div 2;
      h:=(left+right) div 2;
    end;
  end;

  topleft.h:=center.h-170; {position of topleft}
  topleft.v:=center.v-120;

  Cancel:=false;
  SFPutFile(topleft,prompt,orgname,nil,Reply);
  if Reply.good then
      begin

       vol:=reply.vrefnum;
       filename:=reply.fname;

       vserr:=SetVol(nil,vol); {change default volume}

       {SFGetFile does not do an actual open : FSOpen or PBOpen
        are called to do this in the examples I have seen}

        rewrite(filevar,filename); {do turbo open}

        {set file creator}
        if getFinfo(filename,vol,finderinfo)=NoErr then
            begin
               finderinfo.fdCreator:=creator;

               if setFinfo(filename,vol,finderinfo) <> NoErr then
                  begin
                    sysbeep(10);
                    cancel:=true;
                  end
                  ;
            end
        else
            begin
              sysbeep(10);
              cancel:=true;
            end

      end
  else
      begin
      {may be a cancel or other error}
      Cancel:=true;

      end;

end; {of proc MySFopen }
{$S startup}
procedure open_output;
{Open Output file}
var cancel:boolean;
begin
set_default_blessed;
{default folder to the system folder}
mySFnew(outfile,'Output File?','NewSystemCheckSum','EDIT',cancel);
if not cancel then
    begin
    outputopen:=true;
    writeoutputflag:=true;
    end
 else
    begin
    outputopen:=false;
    writeoutputflag:=false;
    end;
set_default_blessed;
end;
{$S event}
procedure open_input;
{look for input file 'OldSystemCheckSum' in startup and blessed folder
if not found ask for it}
label 99;
var savewd:integer;
    err,ierr,ignore:oserr;
    name:str255;
    finder:Finfo;
begin
name:='OldSystemCheckSum';
inputnotdefault:=true;

if inputopen then exit;
ignore:=getvol(nil,savewd);
{startup folder}
ignore:=setvol(nil,startupwd);
err:=GetFInfo(name,0,finder);
if err=noerr then
    begin
      if finder.fdtype='TEXT' THEN
          begin
          reset(infile,name);
          ierr:=IOResult;{turbo pascal error codes}
          if Ierr<>0 then halt_on_error(ierr,'Open Input-default folder');
          inputopen:=true;
          inputnotdefault:=false;
          goto 99;
          end;
    end;
{system folder}
set_default_blessed;
err:=GetFInfo(name,0,finder);
if err=noerr then
    begin
      if finder.fdtype='TEXT' THEN
          begin
          reset(infile,name);
          ierr:=IOResult;{turbo pascal error codes}
          if Ierr<>0 then halt_on_error(ierr,'Open Input-system folder');
          inputopen:=true;
          inputnotdefault:=false;
          goto 99;
          end;
    end;
poststatus(concat('I can''t find: ',name),errorline);
if Ask('Do you want to specify another input file?',nodefaultbut) then
     begin
       poststatus('',errorline);
       mySFold(infile,'Old checksums file',name,cancel);
       if cancel then goto 99;
       inputopen:=true;
       goto 99;
     end
     else
       begin
         poststatus('',errorline);
       end;
99:
ignore:=setvol(nil,savewd);
end;{open_input}

procedure close_and_flush(var filevar:text;var openflag:boolean);
{close file and flush default volume}
var ignore:oserr;
begin
if openflag then close(filevar);
openflag:=false;
ignore:=FlushVol(nil,0);{flush default volume}
end;{procedure close_and_flush}

procedure close_all_and_halt{(beep:boolean)};
{Close input and output files if open and halt}
var ignore:oserr;
begin
if beep then
   begin sysbeep(1);sysbeep(1); end;
if inputopen then close_and_flush(infile,inputopen);
if outputopen then close_and_flush(outfile,outputopen);
closepath(myRpath);
ignore:=setvol(nil,startupwd);
halt;
end;
{$S boot}
function absolute_read(buffer:handle;count:longint;offset:longint):oserr;
{read data from an absolute position-used to check the boot blocks}
var pblock:paramBlockRec;
    mypb:hparamblockrec;
    vname:str255;
    err:oserr;
    drivenum:integer;
    driver:integer;
begin
{get drive number of default volume}
with mypb do
    begin
    iocompletion:=nil;
    vname:='';
    ionameptr:=@vname;
    iovrefnum:=0;
    ioVolIndex:=0;
    end;
scsi_wait;
err:=pbhgetvinfo(@mypb,false);
with mypb do
    begin
      drivenum:=iovdrvinfo;
      driver:=iovdrefnum;
     end;

absolute_read:=err;

if err<>noerr then
   begin
      exit;
   end;

{work on reading the data}
hlock(buffer);
with pblock do
     begin
        iocompletion:=nil;
        iovrefnum:=drivenum;
        iorefnum:=driver;
        iobuffer:=buffer^;
        ioreqcount:=count;
        ioPosMode:=FsFromStart;{relative from first sector}
        ioPosoffset:=offset;
     end;
    scsi_wait;
    err:=PBRead(@pblock,false);
hunlock(buffer);
absolute_read:=err;
end;{proc absolute_read}

{$S boot}
procedure boot_ignore(buffer:handle);
{zero out fields where boot block changes are safe/common}
type boots=array[0..511] of integer;
     bootptr=^boots;
var i:integer;
    p:bootptr;
begin
hlock(buffer);
p:=bootptr(buffer^);
{info that changes on set startup}
for i:=45 to 52 do p^[i]:=0;
hunlock(buffer);
end;

function checksum_boot_blocks{:integer};
var count,offset:longint;
    buffer:handle;
    err:oserr;
    result:integer;
begin
result:=0;
count:=1024;{two logical blocks}
offset:=0;
buffer:=newhandle(count);
if buffer<>nil then
   begin
      err:=absolute_read(buffer,count,offset);
      if err=noerr then
           begin
           boot_ignore(buffer);{zero out safe stuff}
           result:=checksumHdata(buffer);
           end;
      disposHandle(buffer);
   end;

checksum_boot_blocks:=result;

end;{proc}

{$S event}
procedure tefixup(statustext:tehandle);
{shrink the size of the TERec if a bug in TE has made the
linestarts array too big}
var  base,needed,actual:longint;
begin
actual:=gethandlesize(handle(statustext));
{figure nominal size}
base:=sizeof(statustext^^)-sizeof(statustext^^.linestarts);
needed:=(statustext^^.nlines+1)*2+base;
if actual>needed+64 then
    begin
    {reset to needed size plus a bit extra}
       Hunlock(handle(statustext));
       sethandlesize(handle(statustext),needed+8);
    end
end;{procedure tefixup}

procedure replaceline{(ss:str255;linenum:integer)};
{On screen messages}
{replace a line in the statustext TERec}
var start,finish:longint;
    cr:string[1];
begin
cr:=chr(13);
ss:=concat(ss,cr);
if linenum<statustext^^.nlines then
   begin
   start:=statustext^^.linestarts[linenum-1];
   finish:=statustext^^.linestarts[linenum];
   end
else
   begin
   start:=0;
   finish:=0;
   end;
TESetSelect(start,finish,statustext);
TeDeLete(statustext);
TEInsert(Pointer(ord4(@ss)+1),length(ss),statustext);
tefixup(statustext);
TESetSelect(0,0,statustext);
end;

procedure clear_to_end{(linenum:integer)};
{On screen messages}
{clear lines in the statustext TERec from linenum to end}
var start,finish:longint;
    nn:integer;
    cr:string[1];
    ss:str255;
begin
cr:=chr(13);
if linenum<statustext^^.nlines then
   begin
   start:=statustext^^.linestarts[linenum-1];
   finish:=statustext^^.telength;
   end
else
   begin
   start:=0;
   finish:=0;
   end;
{create empty lines as filler}
ss:=cr;
for nn:=linenum to mstatus do ss:=concat(cr,ss);

TESetSelect(start,finish,statustext);
TeDeLete(statustext);
TEInsert(Pointer(ord4(@ss)+1),length(ss),statustext);
TESetSelect(0,0,statustext);
{replace title and byline}
if linenum<=byline then
  begin
Replaceline(concat('Startup System Check ',TitleVersion),titleline);
 ReplaceLine('by Albert Lunde, Northwestern University  Copyright © 1988'
,byline);
  end;

end;

procedure postmem(linenum:integer);
var ff,kk:str255;
begin
if not showdebuginfo then exit;
numtostring(freemem,ff);
kk:=concat('Free memory: ',ff);
poststatus(kk,linenum);
end;
procedure poststatus{(ss:str255;linenum:integer)};
{On screen messages}
{post a message on the screen and go into the event
loop long enought to update the screen or process halt button}
var ff,kk:str255;
begin
(*
numtostring(freemem,ff);
kk:=ff;
numtostring(gethandlesize(handle(statustext)),ff);
kk:=concat(kk,concat(' ',ff));
numtostring(sizeof(resourceinfoarray),ff);
kk:=concat(kk,concat(' ',ff));
*)
replaceline(ss,linenum);
{replaceline(kk,mstatus);}
DoEvent(false);
end;

function Ask{(question:str255;default:integer):boolean};

begin
setdefaultbutton(default);
hidecontrol(buttons[continuebut]);
hidecontrol(buttons[shutdownbut]);
hidecontrol(buttons[haltbut]);
showcontrol(buttons[yesbut]);
showcontrol(buttons[nobut]);
askanswered:=false;
poststatus(question,askline);
sysbeep(1);
repeat
doevent(false);
until askanswered;
setdefaultbutton(nodefaultbut);
clear_to_end(askline);
showcontrol(buttons[continuebut]);
showcontrol(buttons[shutdownbut]);
showcontrol(buttons[haltbut]);
hidecontrol(buttons[yesbut]);
hidecontrol(buttons[nobut]);
ask:=askanswer;
doevent(true);
end;

procedure halt_on_error{(err:oserr;sss:str255)};
{check for OSerr code}
var ss:str255;
begin
if err=noerr then exit;
Numtostring(err,ss);
ss:=concat(concat('Unexpected Error:',ss),sss);
poststatus(ss,errorline);
repeat until button;
close_all_and_halt(true);
end;
{$S files}
procedure folder_info(wdrefnum:integer;
                var dirid:longint;
                var volume:integer;
                var name:str255;
                var path:str255);
{get info (name and path) on a directory specified by either a
16 bit working directory reference number or
a 32 bit id directory ID}
{set wdrefnum zero on input if using a dir id}
{this only seems to work on the current volume}
var vname:str255;
    mywdpb:wdpbrec;
    mycinfopb:cinfopbrec;
    err,ignore:oserr;
    oldwd:integer;
    fail:boolean;
    tempdirid:longint;
    tempname:str255;
    count:integer;
begin
fail:=false;
{save default wd}
ignore:=getvol(nil,oldwd);



if not fail then
with mywdpb do
    begin
        {set up for PBHSet/GetVol call}
         ioCompletion:= NIL;
         vname:='';
         ioNamePtr:= @vName;    {initialize may not be needed}
         ionameptr:=nil;
         iowddirid:=dirid;
         iovrefnum:=wdrefnum;
    end;
scsi_wait;
{do a set then get to make sure we always know the dir id afterwards}
err:=PBHSetVol(@mywdpb,false);
fail:=fail or (err<>noerr);
err:=PBHGetVol(@mywdpb,false);
fail:=fail or (err<>noerr);
if not fail then
   begin
        with mywdpb do
            begin
                {return from PBHGETVol call}
                dirid:=ioWDDIRID;
                volume:=ioWDVRefNum;
            end;{with}
   end;




{now DirID is the 32-bit id of a directory}
if not fail then
    begin
        {Build path}
        {This is based roughly on C code from
        "Programming with Macintosh Programmer's Workshop" by Joel West
        Page 467-469}

        path:='';
        tempdirid:=dirid;{dir ID for folders along the path}
        tempname:='';
        count:=0;{infinite loop protection}
        repeat
          count:=count+1;
          with mycinfopb do
               begin
               {setup for pbgetcatinfo}
               iocompletion:=nil;
               ionameptr:=@tempname;
               iovrefnum:=0;
               iodirid:=tempdirid;
               iofdirindex:=-1;{info about directories only see tn#69}
               end;
               scsi_wait;
               err:=pbgetcatinfo(@mycinfopb,false);
                  if err=noerr then
                    with mycinfopb do
                        begin
                        if count=1 then name:=tempname;
                        path:=concat(tempname,':',path);
                        tempdirid:=iodrparid;
                        end;

        until((count>100) or (tempdirid=fsrtparid) )
    end;{path build}
{restore default wd}
ignore:=setvol(nil,oldwd);
end;{folderinfo}

procedure folder_name{(dirid:longint;var name:str255)};
{get name of a directory specified by a
 32 bit id directory ID}

var vname:str255;
    mywdpb:wdpbrec;
    mycinfopb:cinfopbrec;
    err,ignore:oserr;
    oldwd:integer;
    tempname:str255;
begin
{save default wd}
ignore:=getvol(nil,oldwd);

with mywdpb do
    begin
        {set up for PBHSet/GetVol call}
         ioCompletion:= NIL;
         vname:='';
         ioNamePtr:= @vName;    {initialize may not be needed}
         ionameptr:=nil;
         iowddirid:=dirid;
         iovrefnum:=0;
    end;

scsi_wait;
err:=PBHSetVol(@mywdpb,false);
name:='';
if err=noerr then
    begin
      with mycinfopb do
           begin
           {setup for pbgetcatinfo}
           iocompletion:=nil;
           ionameptr:=@tempname;
           iovrefnum:=0;
           iodirid:=dirid;
           iofdirindex:=-1;{info about directories only see tn#69}
           end;{with}
   scsi_wait;
      err:=pbgetcatinfo(@mycinfopb,false);
         if err=noerr then
           with mycinfopb do
               begin
               name:=tempname;
               end;
    end;{path build}
{restore default wd}
ignore:=setvol(nil,oldwd);
end;{folderinfo}

procedure set_default_blessed;
{set default volume and folder to the blessed(active system) folder}
var
         err: OSErr;
         myWDPB: WDPBRec;
      dummy:str255;
begin
{set default folder to dirID}
with mywdpb do
    begin
        {set up for PBHSetVol call}
         ioCompletion:= NIL;
         dummy:='';
         ioNamePtr:= @dummy;    {initialize may not be needed}
         ionameptr:=nil;
         ioWDDirID:=blessed;
         ioVRefNum:=blessedbootvolwd;
    end;
scsi_wait;
err:=PBHSetVol(@mywdpb,false);

 halt_on_error(err,'PBsetvol-set_default_blessed');


end;{procedure}

procedure set_default_by_id{(DirID:longint)};
{set default folder by 32 bit DirId}
var
         err: OSErr;
         myWDPB: WDPBRec;
      dummy:str255;
begin
{set default folder to dirID}
with mywdpb do
    begin
        {set up for PBHSetVol call}
         ioCompletion:= NIL;
         dummy:='';
         ioNamePtr:= @dummy;    {initialize may not be needed}
         ionameptr:=nil;
         ioWDDirID:=dirID;
         ioVRefNum:=0;
    end;
scsi_wait;
err:=PBHSetVol(@mywdpb,false);

 halt_on_error(err,'PBsetvol-set_default_by_id');


end;{procedure}

PROCEDURE EnumerateCatalog(dirIDToSearch: longint);

{process all files in a folder but ignore subfolders}

VAR

      myCPB: CInfoPBRec;

      err: OSErr;

      myWDPB: WDPBRec;

      TotalFiles,TotalDirectories: LONGINT;
   fname,dummy:str255;

  index:    integer;

    ignore:oserr;
    oldwd:integer;

Begin {EnumerateCatalog}
ignore:=getvol(nil,oldwd);{save old wd}


 TotalFiles:= 0;

    TotalDirectories:= 0;

    err:= PBHGetVol(@myWDPB,FALSE);        {get the default volume}

    with MyCPB do Begin

        iocompletion:= Nil;

        ioNamePtr:= @FName;

        ioVRefNum:= myWDPB.ioVRefNum;      {for now, default vol, set this to what you want}

    End;  {with}

{set default folder to diridtosearch to allow
use of high level calls in called procedures}

 set_default_by_id(diridtosearch);

index:= 1;

    repeat{loop over folder with index}
 doEvent(false);
        FName:= '';  {nil out name}

        myCPB.ioFDirIndex:= index;

        myCPB.ioDrDirID:= dirIDToSearch; {we need to do this every time through}


        err:= PBGetCatInfo(@myCPB,FALSE);



        If err = noErr then

            if BitTst(@myCPB.ioFlAttrib,3) then
      Begin {we have a dir}
                 TotalDirectories:=TotalDirectories+1;
        {do nothing for directories}
                 err:= 0;  {clear error return on way back}
             End {if BitTst}
        Else
      Begin{we have a file}

            TotalFiles:= TotalFiles + 1;

    Poststatus(concat('Checking: ',fname),fileline);
    (* Do_for_file(dirIDToSearch,MyCPB.ioFrefNum,Fname,Totalfiles,MYCPB)*)
     sysfiles[index]:=fname;
    check_a_file(index);
        End; {else}
  PostStatus('',fileline);
        index:= index + 1;

    until err <> noErr;

ignore:=setvol(nil,oldwd); {restore WD}

End;  {EnumerateCatalog}

procedure get_blessed;
{get the blessed folder 32 bit dir id,
given either volume ref or a working directory ref on that volume}
{this version stores the blessed folder id and the working dir ref
of the boot volume in global variables}
CONST

    FSFCBLen    = $3F6;      {location of low-memory global FSFCBLen}


VAR

    myHPB: HParamBlockRec;    {for the PBHGetVInfo call}

    myWDPB: WDPBRec;        {for the PBHSetVol call}

    err,ignore: OSErr;

    oldVol: integer;

    vName,fName: str255;

    HFS: ^integer;        {to check to see if we are running HFS}
 bootwdptr: ^integer;    {to find the boot drive}
 oldwd:integer;

begin
  {save default wd}
  ignore:=getvol(nil,oldwd);

       HFS:= POINTER(FSFCBLen);    {point our variable at the low-memory global}

    if HFS^ > 0 then Begin     {we're running HFS}

  blessedbootvolwd:=GetRealBootDrive;
  {"working directory reference number" for system startup volume}

  {change to system startup volume - this is so we always find the
   blessed folder on the startup device, even when running from a floppy}

  ignore:=setvol(nil ,blessedbootvolwd);

        vName:= '';        {initialize this}

        with myHPB do Begin

            ioCompletion:= NIL;

            ioNamePtr:= @vName;    {initialize}

            ioVRefNum:= 0;     {0 is get for default volume}

            ioVolIndex:= 0;    {we're not making indexed calls}


        End;  {with}



        err:= PBHGetVInfo(@myHPB,FALSE);

        if err <> 0 then poststatus('PBHGetVInfo Error',errorline)

        Else


    End {if HFS^ > 0}
;
{At this point, the dirID of the blessed folder on the volume}
blessed:=myHPB.ioVFndrInfo[1];
{writeln(vname);}
{restore default wd}
ignore:=setvol(nil,oldwd);


end;{get blessed}

{$S core}
procedure filltype{(var tt:restype;ss:str255)};
{blank fill and convert string to resource type}
var work:string[8];
begin
 work:=concat(ss,'    ');
tt[1]:=work[1];
tt[2]:=work[2];
tt[3]:=work[3];
tt[4]:=work[4];
end;{fill type}

{$S startup}
procedure read_input_header;
{read beginning of input file before resource types list}
var ignore:str255;
begin
if not inputopen then exit;
{Mac SE:System Folder: path,date,time,version
12742                  bootblockchecksum
789087                 checksumchecksum
322 104 322            resource counts
*****                  end of header}
if eof(infile) then exit;
read_input(ignore);{path}
if eof(infile) then exit;
oldbootblockchecksum:=0;
read_input_integer(oldbootblockchecksum);{grand resource checksum}

if eof(infile) then exit;
oldchecksumchecksum:=0;
read_input_long(oldchecksumchecksum);  {boot block checksum}

{skip down to *****}
repeat
if eof(infile) then exit;
read_input(ignore);
until(test_end_flag(ignore));

read_safekeys;
read_morechecks;
end;{proc}

procedure readoklist;
{read a list of resource types/stop at eof or "*****"}
{each line contains TYPE,safety level,and optional number of occurances}
label 99;
var line:str255;
    ntokens:integer;
    tokens:tokenstype;
    atype:restype;
    howsafe:safetype;
    work:longint;
begin
if not inputopen then exit;
PostStatus('Reading safe types list',fileline);
while(not eof(infile)) do
   begin
      line:='';
      read_input(line);
      {sysbeep(1);
      poststatus(line,fileline);}
      if test_end_flag(line) then goto 99;
      tabscan(line,tokens,ntokens);
     { poststatus(concat(concat('$',tokens[1]),'$'),errorline);}
      if ntokens>=2 then
          begin
            filltype(atype,tokens[1]);
            work:=ord(unknown);
            stringtonum(tokens[2],work);
            if (work>3) or (work<0) then
                 begin
                 poststatus(concat('Bad input:',line),errorline);
                 wait_for_buttons(' ',continuebut);
                 howsafe:=unknown;
                 end
            else
                 howsafe:=safetype(work);
            add_type(atype,howsafe);
          end
      else if ntokens=1 then
          begin
            filltype(atype,tokens[1]);
            add_type(atype,safe);
          end;

   end;{while}
99:
PostStatus('',fileline);
end;{readoklist}

{$S sortres}
        procedure sortresources(var X:resourceinfoarrayptr;N:integer);
        {sort array of resources and their checksums}
{        HEAP SORT
C
C       BASED ON PROGRAMMING PEARLS BY JON BENTLEY P 182
C       X IS THE ARRAY CONTAINING NX ELEMENTS TO BE SORTED
C       CALL SWAPX(I,J) SWAPS X(I) WITH X(J)
C       GEX(X,I,J) IS TRUE IFF X(I) >= X(J)
C       GTX(X,I,J) IS TRUE IFF X(I) > X(J)
C}


       var i: integer;


procedure SWAPX(I:integer;J:integer);
var     T:resourceinforec;

begin
        T:=X^[I];
        X^[I]:=X^[J];
        X^[J]:=T;
END; {of procedure swapx}

FUNCTION GTX(I:integer;J:integer):boolean;
var filecomp:integer;
begin
       {sort type,id,size }
       gtx:=false;

        filecomp:=filenamecompare(
            sysfiles[(X^[I].filenameindex and fnamemask)],
            sysfiles[(X^[J].filenameindex and fnamemask)]);

        if filecomp>0
          {(sysfiles[(X^[I].filenameindex and fnamemask)]>
            sysfiles[(X^[J].filenameindex and fnamemask)])} then
           begin
            gtx:=true
           end
        else if filecomp=0
               {((X^[I].filenameindex and fnamemask)=
                 (X^[J].filenameindex and fnamemask))} then
             if (X^[I].thetype>X^[J].thetype) then
                begin
                 gtx:=true
                end
             else if (X^[I].thetype=X^[J].thetype) then
                begin
                  if (X^[I].theid>X^[J].theid)then
                      begin
                          gtx:=true;
                      end
                  else if (X^[I].theid=X^[J].theid)then
                      begin
                        if (X^[I].thesize>X^[J].thesize)then
                            begin
                              gtx:=true;
                            end
                      end
                   ;
                 end
             ;

end;

FUNCTION GEX(I:integer;J:integer):boolean;
var filecomp:integer;
begin
       {sort type,id,size }
       gex:=false;

        filecomp:=filenamecompare(
            sysfiles[(X^[I].filenameindex and fnamemask)],
            sysfiles[(X^[J].filenameindex and fnamemask)]);

       if filecomp>0
         {(sysfiles[(X^[I].filenameindex and fnamemask)]>
           sysfiles[(X^[J].filenameindex and fnamemask)])} then
           begin
            gex:=true
           end
        else if filecomp=0
               {((X^[I].filenameindex and fnamemask)=
                 (X^[J].filenameindex and fnamemask))} then
           if (X^[I].thetype>X^[J].thetype) then
              begin
               gex:=true
              end
           else if (X^[I].thetype=X^[J].thetype) then
              begin
                if (X^[I].theid>X^[J].theid)then
                    begin
                        gex:=true;
                    end
                else if (X^[I].theid=X^[J].theid)then
                    begin
                     if (X^[I].thesize>=X^[J].thesize)then
                         begin
                           gex:=true;
                         end
                    end
                 ;
               end
           ;

END;

procedure siftdown(L:integer;U:integer);
    label 300,999{return};
    var
        i,child:integer;

begin

{
C
C       BEFORE MAXHEAP(L+1,U)
C       AFTER  MAXHEAP(L,U)
}
        I:=L;

        {LOOP}
300:
{
C               INVARIANT: MAXHEAP(L,U) EXCEPT PERHAPS
C                       BETWEEN I AND ITS (0,1 OR 2) CHILDREN
C
}
                CHILD:=2*I;

                IF CHILD > U  then goto 999;
{
C
C               IF C+1 <= U AND X^(C+1) > X^(C) THEN C=C+1
C
}
                IF(CHILD+1 <= U) THEN
                IF(GTX(CHILD+1,CHILD))THEN
                        CHILD:=CHILD+1;

{
C
C               CHILD IS THE GREATEST CHILD OF I
C
C               IF X^(I) >= X^(CHILD) THEN RETURN
C
}
                IF(GEX(I,CHILD)) then goto 999;

{
C
C               X^(I) IS LESS THAN ITS GREATEST CHILD SO SWAP IT DOWNWARD
C               AND REPEAT LOOP
C
}
                SWAPX(CHILD,I);
                I:=CHILD;
                GOTO 300;
        {END LOOP}
999:{return}
END; {of proc siftdown}



begin {main body of sortresources}

        for I:=N div 2 downto 1 do
        begin
       { echo(i);}
        SIFTDOWN(I,N);
        end;

        {echo(0);}

        for I:=N downto 2 do
        begin
          {  echo(i);}
                SWAPX(1,I);
                {echo(i);}
                SIFTDOWN(1,I-1);
               { echo(i);}
         end;



END; {sortresources}

        procedure sorttypes{(var X:resourcetypeinfoarray;N:integer)};
        {sort resource types array}
{        HEAP SORT
C
C       BASED ON PROGRAMMING PEARLS BY JON BENTLEY P 182
C       X IS THE ARRAY CONTAINING NX ELEMENTS TO BE SORTED
C       CALL SWAPX(I,J) SWAPS X(I) WITH X(J)
C       GEX(X,I,J) IS TRUE IFF X(I) >= X(J)
C       GTX(X,I,J) IS TRUE IFF X(I) > X(J)
C}


       var i: integer;


procedure SWAPX(I:integer;J:integer);
var     T:resourcetypeinforec;

begin
        T:=X[I];
        X[I]:=X[J];
        X[J]:=T;
END; {of procedure swapx}

FUNCTION GTX(I:integer;J:integer):boolean;

begin
       {sort type,id,size }
       gtx:=false;
            if (X[I].thetype>X[J].thetype) then
                begin
                        gtx:=true;
                 end
             ;

end;

FUNCTION GEX(I:integer;J:integer):boolean;

begin
       {sort type,id,size }
       gex:=false;
           if (X[I].thetype>=X[J].thetype) then
              begin
               gex:=true
              end

END;

procedure siftdown(L:integer;U:integer);
    label 300,999{return};
    var
        i,child:integer;

begin

{
C
C       BEFORE MAXHEAP(L+1,U)
C       AFTER  MAXHEAP(L,U)
}
        I:=L;

        {LOOP}
300:
{
C               INVARIANT: MAXHEAP(L,U) EXCEPT PERHAPS
C                       BETWEEN I AND ITS (0,1 OR 2) CHILDREN
C
}
                CHILD:=2*I;

                IF CHILD > U  then goto 999;
{
C
C               IF C+1 <= U AND X(C+1) > X(C) THEN C=C+1
C
}
                IF(CHILD+1 <= U) THEN
                IF(GTX(CHILD+1,CHILD))THEN
                        CHILD:=CHILD+1;

{
C
C               CHILD IS THE GREATEST CHILD OF I
C
C               IF X(I) >= X(CHILD) THEN RETURN
C
}
                IF(GEX(I,CHILD)) then goto 999;

{
C
C               X(I) IS LESS THAN ITS GREATEST CHILD SO SWAP IT DOWNWARD
C               AND REPEAT LOOP
C
}
                SWAPX(CHILD,I);
                I:=CHILD;
                GOTO 300;
        {END LOOP}
999:{return}
END; {of proc siftdown}



begin {main body of sorttypes}

        for I:=N div 2 downto 1 do
        begin
       { echo(i);}
        SIFTDOWN(I,N);
        end;

        {echo(0);}

        for I:=N downto 2 do
        begin
          {  echo(i);}
                SWAPX(1,I);
                {echo(i);}
                SIFTDOWN(1,I-1);
               { echo(i);}
         end;



END; {sorttypes}
{$S wascore}
function min(i,j:longint):longint;
begin
if i<j then min:=i else min:=j;
end;
function rotatelong(i:longint):longint;
{left circular shift by one bit}
const leftbitnum=0;
      rightbitnum=31;
var j:longint;
begin
j:=BitShift(i,1);{left logical shift one}
if bittst(@i,leftbitnum) then
    begin
    {high bit set in i}
    bitset(@j,rightbitnum);
    end
  ;
rotatelong:=j;
end;

function checksumHdataOLD{(h:handle):integer};
{OLD version using the toolbox bit manipulation stuff
 and an intermediate buffer array (abount 10 times slower)}
{non-standard checksum for virus detection
 depends on all bits and can detect  transpositions}
{modified to increase non-linearity 3/29/88}
const mask=$00FFFFFF;
      blocklongsize=64;
      blockbytesize=256;{4x above}
var size:longint;
    p:ptr;
    p0:longint;
    sum:integer;
    lsum:longint;
    offset:longint;
    longxxxx:longint;
    j,kk:longint;
    work:array[1..blocklongsize] of longint;
begin
sum:=0;
lsum:=0;
longxxxx:=0;
if h<>nil then
  if (h^<>nil) then
     begin
     size:=GetHandleSize(h);
     offset:=0;
     while offset<(size-1) do
        begin

        for j:=1 to blocklongsize do work[j]:=0;
        p0:=bitand(mask,ord4(h^));
        p:=pointer(p0+offset);
        kk:=min(longint(blockbytesize),size-offset);
        blockmove(p,@work,kk);{copy a block}
        for j:=1 to (kk+3) div 4 do {do for longints}
           begin
              lsum:=bitxor(lsum,work[j]);
              longxxxx:=longxxxx+checksumsaltinc;
              {lsum:=bitxor(lsum,longxxxx);}{3/29/88}
              lsum:=lsum+longxxxx;
              lsum:=rotatelong(lsum);
           end;
        offset:=offset+blockbytesize;
        end;
     sum:=loword(bitxor(longint(loword(lsum)),longint(hiword(lsum)) ));
     end;

checksumhdataOLD:=sum;

end;
{$S core}
function checksumHdata{(h:handle):integer};
{faster version using more stuff specific to turbo pascal 3/28/88}
{non-standard checksum for virus detection
 depends on all bits and can detect  transpositions}
{modified to use Turbo's inline code bit masking operators
 rather than the toolbox bitxor etc}
{modified to operate directly on the data in the handle
 rather than copying blocks into a buffer}
{modified to increase non-linearity 3/29/88}
const mask=$00FFFFFF;
      leftbitmask= $80000000;
      rightbitmask=$00000001;
      blocklongsize=8000;
      blockbytesize=32000;{4x above}
type workblocktype=array[1..blocklongsize] of longint;
     workptr=^workblocktype;
var size,realsize,sizeextra:longint;
    p:ptr;
    wrk:workptr;
    p0:longint;
    sum:integer;
    lsum:longint;
    offset:longint;
    longxxxx:longint;
    j,kk:longint;
    shwork:longint;
    last:longint;
begin
sum:=0;
lsum:=0;
longxxxx:=0;
if h<>nil then
  if (h^<>nil) then
     begin
     hlock(h);
     size:=GetHandleSize(h);
     realsize:=size;
     sizeextra:=size mod 4;
     size:=size-sizeextra;
     offset:=0;
     p0:=bitand(mask,ord4(h^));
     while offset<(size-1) do
        begin
        p:=pointer(p0+offset);
        kk:=min(longint(blockbytesize),size-offset);
        wrk:=workptr(p);
        for j:=1 to (kk+3) div 4 do {do for longints}
           begin
              lsum:=(lsum xor wrk^[j]);
              longxxxx:=longxxxx+checksumsaltinc;
              {lsum:=(lsum xor longxxxx);}{3/29/88}
              lsum:=lsum+longxxxx;

              {simulate a left circular shift of one on lsum}
              shwork:=lsum shl 1;{left logical shift one}
              if (lsum and leftbitmask)<>0 then
                  begin
                  {high bit set in lsum}
                  shwork:=shwork or rightbitmask
                  end;
               lsum:=shwork;
               {end shift}
           end;
        offset:=offset+blockbytesize;
        end;
     if sizeextra<>0 then
     begin
     {special case for trailing bytes in last longword}
     wrk:=workptr(pointer(p0+size));
     last:=wrk^[1];
     case sizeextra of
     1:last:=last and $FF000000;
     2:last:=last and $FFFF0000;
     3:last:=last and $FFFFFF00;
     end;{case}
           begin{copy of code above except 1st line}
              lsum:=(lsum xor last);
              longxxxx:=longxxxx+checksumsaltinc;
              {lsum:=(lsum xor longxxxx);}{3/29/88}
              lsum:=lsum+longxxxx;

              {simulate a left circular shift of one on lsum}
              shwork:=lsum shl 1;{left logical shift one}
              if (lsum and leftbitmask)<>0 then
                  begin
                  {high bit set in lsum}
                  shwork:=shwork or rightbitmask
                  end;
               lsum:=shwork;
               {end shift}
           end;

     end;{sizeextra non-zero}
     sum:=loword(bitxor(longint(loword(lsum)),longint(hiword(lsum)) ));
     hunlock(h);
     end;

checksumhdata:=sum;
end;{function}

{$S core}
procedure check_all_types(filename:str255;
                    fnindex:integer;{index of file name - system folder checks only}
                    apindex:integer;{subscript of application - application checks only}
                    SYSTEMFOLDER:boolean);{true for system check, false for application check}
{This is the routine that checks all types in a given file}
 {called by check_a_file}
const
    keymousemask=62;{all mouse and key events}
    applsalt=$1234;{to make application checksum over resources non-linear}
var
    j:integer;
    tt:restype;
    ok:boolean;
    err:oserr;
    index:integer;
    itt:integer;
    CHECKIT:BOOLEAN;
    sl:safetype;
    rhand:handle;
    rid:integer;
    rsize:longint;
    rattr:integer;
    rname:str255;
    aevent:EventRecord;
    volref:integer;
begin
   {dbashow;}
   {Open resource fork as a file and load the
     header info into my own data structures}

   if systemfolder then
      begin
          sl:=filenamesafetylevel(filename);
      end
   else
      begin
          sl:=unknown;
      end;
   volref:=0;{look in default directory}
   err:=openpath(myRpath,filename,volref);

   if err=noerr then
   with myRpath do
   begin
      { ntypes number of resource types in the current resource file}
     { dbashow;}
     { wait_for_buttons(' start types',continuebut);}
      for j:=1 to ntypes do
      if setmytype(myRpath,j,tt) then
         begin
         {breakout on mouse,key events}
         if EventAvail(keymousemask,aevent) then DoEvent(true);
         {nrefs is count of this type}
           {poststatus(concat(concat('$',tt),'$'),resline);}
            if showdebuginfo then poststatus(tt,resline);

           if systemfolder then add_type(tt,unknown);{the detailed list of types
                                                     is for the system folder only
                                                     except for "dangerous" types}

           {decide what types should be checked}
           itt:=find_type(tt);
           CHECKIT:=(tt='INIT') or (tt='CODE');
           if itt<>0 then
               with rtypes[itt] do
                  begin
                    checkit:=safety>sl;{check resources above
                    safe or unknown depending on file,location}
                    if (not systemfolder) and (safety=dangerous) then
                        begin
                            {record dangerous types in applications}
                            ainfo^[apindex].flags:=
                            ainfo^[apindex].flags or appldangermask
                        end;
                    if (systemfolder) or (safety=dangerous) then
                    begin
                    occurs:=occurs+nrefs;
                    if checkit then
                        notsafecount:=notsafecount+nrefs;
                    end;
                  end;

           if checkit then
             begin
             for index:=1 to nrefs do
                begin
                  {copy resource data and get name and size}
                  if CopyResData(myRpath,index,
                         rid,rsize,rattr,rname) then
                  if systemfolder then
                    begin
                    {system folder check}
                     if rcount<maxinfo then
                        begin
                          rcount:=rcount+1;
                          with rinfo^[rcount] do
                            begin
                              thetype:=tt;
                              theid:=rid;
                              filenameindex:=fnindex;
                              thesize:=rsize;
                              thename:=rname;
                              checksum:=0;{in case all else fails}
                              {dbashow;}
                              {compute checksums}
                              checksum:=checksumHdata(resdata);
                              checksumchecksum:=checksumchecksum+checksum;
                            end;{with}
                         end;{rcount<maxinfo/rhand<>nil}
                    end
                  else
                    begin
                      {application check}
                       with ainfo^[apindex] do
                         begin
                            if unsafecount<0 then unsafecount:=0;
                            unsafecount:=unsafecount+1;
                            checksize:=checksize+rsize;
                            {compute checksums}
                            checksum:=(checksum xor applsalt)+checksumHdata(resdata);
                         end;
                    end
                  {dbashow;}
                  end;{for index}
              end;{if checkit}
         {dbashow;}
         end;{for types/set ok}
   end;{if open ok/with mypath}

closepath(myRpath);
{dbashow;}
end;{proc check_all_types}



procedure check_a_file{(index:integer)};

var
    i:integer;
    filename:str255;
    volref:integer;
begin
filename:=sysfiles[index];
postmem(memline);
check_all_types(filename,index,1,true);
end;
{$S appl}
procedure checksum_all_appl;
{go back and checksum applications
 from list in memory}
 var i:integer;
     oldvol:integer;
     ignore:oserr;
     percent:longint;
     pct:str255;
     err:oserr;
     vr:integer;
begin
if fastapplcheck then exit;{skip in fast mode}
ignore:=getvol(nil,oldvol);
set_default_blessed;
for i:=1 to acount do
    with ainfo^[i] do
  begin
     vr:=newvols[flags and applvolumemask].volrefnum;
     err:=setvol(nil,vr);
     if err=noerr then
        begin
          set_default_by_id(dirid);{set directory}
          percent:=i*100;
          percent:=percent div acount;
          numtostring(percent,pct);
          pct:=concat(pct,'%');
          pct:=concat(concat(filename,' '),pct);
          poststatus(pct,fileline);
          check_all_types(filename,1,i,false);
        end;
  end;
clear_to_end(fileline);
ignore:=setvol(nil,oldvol);
end;{proc}
{$S core}
procedure summary;
{write summary to output file in same format as input file}
var i:integer;
    tab:string[1];
    now:longint;
    ndate,ntime:str255;
begin
if not writeoutputflag then exit;
{-----------------------------------}
tab:=chr(9);
poststatus('Writing System Summary Output',pathline);

{get time stamp}
getdatetime(now);
IUDateString(now,abbrevdate,ndate);
IUTImeString(now,false,ntime);
scsi_wait;
writeln(outfile,blessedpath,tab,ndate,tab,ntime,tab,titleversion);
scsi_wait;
writeln(outfile,bootblockchecksum);
scsi_wait;
writeln(outfile,checksumchecksum);{grand checksum}
scsi_wait;
writeln(outfile,rcount,tab,rtypes_count,tab,notsafecount);
write_end_flag('end header');
write_safekeys;
write_morechecks;
{end of "header"}
write_vols;{volumes list}
for i:=1 to rtypes_count do
    begin
    with rtypes[i] do
       begin
          scsi_wait;
          writeln(outfile,thetype,tab,ord(safety),tab,occurs);
       end;
    end;
write_end_flag('end types');
for i:=1 to rcount do
    with rinfo^[i] do
      begin
     scsi_wait;
      write(outfile,
      thetype:4,tab,theid:7,tab,thesize:10,tab,
      checksum:7,tab,thename,tab,sysfiles[(filenameindex and fnamemask)]);
if inputopen then
      begin
      if (filenameindex and exactmatchmask)=exactmatchmask then
           begin
           {normal}
           writeln(outfile);
           end
      else
         begin
           if (filenameindex and idmatchmask)=idmatchmask then
              begin
              writeln(outfile,tab,'changed??');
              end
           else
              begin
              writeln(outfile,tab,'new??');
              end
         end;
      end
      else
           begin
           {normal no input file}
           writeln(outfile)
           end;

      end;{for}
write_end_flag('end res checks');
end;{proc summary}

{$S core}
procedure get_set_blessed;
{get the blessed folder and make it the default and
build it's pathname}
var
    volume:integer;
    name:str255;
begin
get_blessed;
set_default_blessed;
folder_info(0,blessed,volume,name,blessedpath);
end;{proc}


procedure docheck;
{top level procedure for the section of the program that
does the work. Note there is no main event loop in the usual sense
I call DoEvent from all over, mostly when posting progress
messages on the screen and loop till I get a null event}

begin
rcount:=0;
acount:=0;
{display the system folder}
poststatus(blessedpath,pathline);

{checksum the boot blocks}
poststatus('Checking boot blocks',fileline);
bootblockchecksum:=checksum_boot_blocks;

{checksum all resources in the system folder}
enumeratecatalog(blessed);
poststatus('Sort Resources',fileline);
sortresources(rinfo,rcount);
clear_to_end(fileline);
{compare over-all checksums}
if inputopen then
   begin
   if bootblockchecksum<>oldbootblockchecksum then
    begin
      Wait_for_buttons('The boot blocks appear to have changed',continuebut);
    end;
   if checksumchecksum<>oldchecksumchecksum then
    begin
      Wait_for_buttons('The over-all checksum of resources has changed',continuebut);
    end;
   end;{if inputopen}
detail_resource_check;
show_detail_changes;
{write summary output file}
{summary;}

poststatus('',resline);
(*close_and_flush(outfile,outputopen);*)
end;{docheck}

{$S events}
procedure dokeypress;
{key events
  ignore modifier keys
  Q is quit
  . is halt
  F is Full Check on start up
  A is system only check on startup
  * is debugger
  Y N are replies to questions Yes and No
  return is default button if any}
var
    whichWindow :   WindowPtr;
    chcode:integer;
    ch:str255;
    menuchoice:longint;

begin
   with theevent do
        begin
           chcode:=bitand(message,CharCodeMask);
           ch:=chr(chcode);
           uprstring(ch,true);
           if (ch='Q') then
              begin
               quitting:=true;
              end
           else if (ch='*') then
              begin
                showdebuginfo:=true;
                debugger;{Macsbug}
              end
           else if (ch='Y') and (not askanswered) then
              begin
                dobutton(yesbut);
              end
           else if (ch='N') and (not askanswered) then
              begin
                dobutton(nobut);
              end
           else if (ch='A') and (not askanswered) then
              begin
                dobutton(sysonlybut);
              end
           else if (ch='F') and (not askanswered) then
              begin
                dobutton(fullbut);
              end
           else if (ch='.') then
              begin
                halt;{emergency exit}
              end
            else if (chcode=13) and (not askanswered) then
              begin
                 dobutton(defaultbutton);
              end
            else
              begin
                sysbeep(1);
              end
         end;{with}

end;

procedure drawlong(l:longint);
var s:str255;
begin
   NumtoString(l,s);
   DrawString(concat(s,' '));
end;

procedure drawbuttons;
{draw buttons and frame around the default}
var
   saveport:grafptr;
   wait,endtick:longint;
   h,v:integer;
   ii:integer;
   rr:rect;
begin
getport(saveport);
setport(mainwindow);
(*
{zap invisibles}
for ii:=1 to mbutton do
    if buttons[ii]^^.contrlVis<>255 then
    begin
     rr:=buttonrects[ii];
     insetrect(rr,-4,-4);
     eraseroundrect(rr,22,22);
    end;
*)
{draw visibles}
for ii:=1 to mbutton do
    if buttons[ii]^^.contrlVis=255 then
    begin
     rr:=buttonrects[ii];
     if (ii=defaultbutton) then forecolor(blackcolor) else forecolor(whitecolor);
     insetrect(rr,-4,-4);
     pensize(2,2);
     frameroundrect(rr,22,22);
     pensize(1,1);
    end;
forecolor(blackcolor);
drawcontrols(mainwindow);
setport(saveport);
end;

procedure showstatus;
{redraw the status message display and buttons}
var
   saveport:grafptr;
   wait,endtick:longint;
   h,v:integer;
begin
getport(saveport);
setport(mainwindow);
EraseRect(mainwindow^.portrect);
teupdate(textbounds,statustext);
framerect(textframe);
drawbuttons;
setport(saveport);
end;

procedure  doshutdown;
{flush drives and do a system shutdown}
const maxdrive=32;
var theerr:oserr;
    volref:integer;
    freebytes:longint;
    drive:integer;
    vname:str255;
begin
flushevents(everyevent,0);  {clear out event queue}
{flush default volume}
theerr:=FlushVol(nil,0);
{loop over small drive numbers to try and flush the rest}

for drive:=1 to maxdrive do begin
   theerr:=getvinfo(drive,@vname,volref,freebytes);
   if theerr=noerr then
      begin
         {writeln(theerr,' ',vname,' ',drive);}
         theerr:=FlushVol(nil,drive);
         {writeln(theerr);}
         theerr:=eject(nil,drive);
         {writeln(theerr);}
      end
   end;

ShutDwnPower;
end;{doshutdown}

procedure dobutton{(whichbutton:integer)};
{actions for buttons and default buttons}
begin
case whichbutton of
  nodefaultbut:{do nothing};
  continuebut:
               begin
                   {continue}
                 askanswered:=true;
                end;
  haltbut:
               begin
                 {halt}
                 close_all_and_halt(true);
                 askanswered:=true;
               end;
   skipitbut:
               begin
                 {same as halt}
                 close_all_and_halt(true);
                 askanswered:=true;
               end;
 shutdownbut:
               begin
                 {Shutdown}
                 doshutdown;
                 askanswered:=true;
               end;
  yesbut:
               begin
                 {yes}
                 askanswer:=true;
                 askanswered:=true;
               end;
  nobut:
               begin
                 {no}
                 askanswer:=false;
                 askanswered:=true;
               end;
  shortbut:
               begin
                 {short check}
                 fastapplcheck:=true;
                 skipapplcheck:=false;
                 askanswered:=true;
               end;
  sysonlybut:
               begin
                 {short check}
                 fastapplcheck:=true;
                 skipapplcheck:=true;
                 askanswered:=true;
               end;
  fullbut:
               begin
                 {full check}
                 fastapplcheck:=false;
                 skipapplcheck:=false;
                 askanswered:=true;
               end;
    end;{case}

end;{proc}
procedure DoControls(whichwindow:windowptr;local:point);
{process hits on controls}
label 88;
var whichcontrol:controlhandle;
    part,tresult:integer;
    wait,endwait:longint;
    jbut:integer;
begin
setport(whichwindow);
part:=findcontrol(local,whichwindow,whichcontrol);
if (part<>0) and (whichcontrol<>nil) then
   begin
   HiLiteControl(whichcontrol,part);{highlight part}
   drawbuttons;
   wait:=30;
   delay(wait,endwait);
   case part of
   InButton:
      begin
        if trackcontrol(whichcontrol,local,nil)<>0 then
          begin
          for jbut:=1 to mbutton do
            if whichcontrol=buttons[jbut] then
               begin
                 dobutton(jbut);
                 goto 88;
                end;
          end;
      end;
   end;{case}
   88:
    HiLiteControl(whichcontrol,0);{unhighlight}
    drawbuttons;
   end;

end;

procedure doclick;
{process mouse down events}
var whichwindow:windowptr;
    global,local:point;
    saveport:grafptr;
    inwhat:integer;
begin
getport(saveport);
    global:=theEvent.where;
    inwhat:=findwindow(global,whichwindow);
    if whichwindow<>nil then
        begin
        setport(whichwindow);
        end;
     local:=global;
     globaltolocal(local);
     case inwhat of
         indesk:;
         inmenubar:;
         insyswindow:;
         incontent:
            begin
            DoControls(whichwindow,local);
            end;
         indrag:;
         ingrow:;
         ingoaway:quitting:=true;
         end;{case}

setport(saveport);
end;

procedure DoNull(dontloop:boolean);
{background/idle Event processing}
begin
if Quitting and (TheEvent.what = NullEvent) then
     begin
        finished:=true;
        close_all_and_halt(true);
     end {if}
else if (theevent.what =nullevent)  then
     begin

       {showstatus;}
        if lowmemoryGZflag then low_memory_halt;
     end;

end;{DoNull}
procedure eventmonitor;
{for debugging}
var s1,s2,s3:str255;
begin
NumToString(longint(theevent.what),s1);
case theevent.what of
    NullEvent:s1:='Null';
    MouseDown:s1:='MouseDn';
    MouseUp:s1:='MouseUp';
    UpdateEvt:s1:='Update';
    ActivateEvt:begin
                 if odd(theevent.modifiers) then s1:='Act' else s1:='DeAct';
                end;
    otherwise
       {pass s1 as is}
end;{case}
numtostring(longint(theevent.modifiers),s2);
s3:=concat(s1, ' ',s2);
{debug_mess(s3);}
end;
procedure doevent{(dontloop:boolean)};
{modified event loop for calling with other routines
 process events till it sees a null event if dontloop is false}
var
    looplimiter:integer;
    Eventstatus:boolean;{indicates if we should handle this event}
    oureventmask:integer;
    savemouse:EventRecord;
    foundin:integer;
 begin
 looplimiter:=0;
 repeat
       looplimiter:=looplimiter+1;
       oureventmask:=EveryEvent;
       begin
      systemtask;
      EventStatus:=GetNextEvent(oureventmask,TheEvent);
      end;

    {Event Processing:}
        if EventStatus then
             case TheEvent.what of
                MouseDown:
                    begin
                   {use mousedown to test option key}
                   optionkeyflag:=optionkeyflag or
                       (bitand(theevent.modifiers,optionkey)<>0);
                    DoClick;
                    end;
                MouseUp:
                   begin
                   end;
                UpdateEvt:
                   begin
                   beginupdate(mainwindow);
                   drawbuttons;
                   showstatus;
                   endupdate(mainwindow);
                   end;
                ActivateEvt:
                   begin
                   {use activate to test option key}
                   optionkeyflag:=optionkeyflag or
                       (bitand(theevent.modifiers,optionkey)<>0);
                   end;
                KeyDown,AutoKey:
                   begin
                   Dokeypress;
                   end;
                otherwise
              end{case}
           {nullevents:}
           else if (theevent.what =nullevent) then
              DoNull(dontloop);
until((theevent.what=nullevent) or (dontloop) or (looplimiter>20))

end; {of proc DoEvent}
{$S startup}
procedure centerit(var rr:rect;height:integer;width:integer);
{center a rectangle on the screen}
var at:point;
begin
rr:=screenbits.bounds;
insetrect(rr,40,40);
with at do
  begin
  with screenbits.bounds do
    begin
      v:=(top+bottom) div 2;
      h:=(left+right) div 2;
    end;
  with rr do
    begin
      top:=v-(height div 2);
      bottom:=v+(height div 2);
      left:=h-(width div 2);
      right:=h+(width div 2);
    end;
  end;
end;{proc centerit}

procedure mytextsetup;
{set up textedit record to display status information}
var i:integer;
    ll:integer;
begin

{define rect for textedit record for posting messages}
textbounds:=wbounds;
globaltolocal(textbounds.topleft);
globaltolocal(textbounds.botright);
insetrect(textbounds,10,10);
textbounds.bottom:=textbounds.bottom-60;
textframe:=textbounds;
Insetrect(textframe,-1,-1);
framerect(textframe);

{create TE Record}
statustext:=TENew(textbounds,textbounds);
{set to centered justification}
TeSetJust(tejustcenter,statustext);
{set to wider spacing}
with statustext^^ do
   begin
     {ll:=lineHeight div 2;}
     ll:=5;
     lineheight:=lineheight+ll;
     fontascent:=fontascent+ll;
   end;
tecaltext(statustext);
{insert empty lines}
for i:=1 to mstatus+1 do replaceline(' ',i);
{put in startup info}
Replaceline(concat('Startup System Check ',TitleVersion),titleline);
ReplaceLine('by Albert Lunde, Northwestern University  Copyright © 1988'
,byline);
replaceline(startversion,fileline);
{set inactive to hide insertion point}
tedeactivate(statustext);
framerect(textframe);
end;

procedure initialize;

var i:integer;
    ignore:oserr;
begin
rinfo:=nil;
ainfo:=nil;
rcount:=0;
acount:=0;
currentvolumesubscript:=0;
showdebuginfo:=false;
scsi_wait_count:=scsi_wait_limit div 2;
defaultbutton:=startupdefaultbutton;
askanswered:=false;
checksumchecksum:=0;
fastapplcheck:=true;
skipapplcheck:=false;
finished:=false;
quitting:=false;
mainwindow:=nil;
inputopen:=false;
outputopen:=false;
optionkeyflag:=false;
notsafecount:=0;

MaxApplZone;
MoreMasters;
MoreMasters;
MoreMasters;
MoreMasters;
FlushEvents(everyevent,0);
InitGraf(@thePort);
InitFonts;
InitWindows;
InitCursor;
TEInit;
for i:=1 to dbamax do dbarray[i]:=0;
ignore:=getvol(nil,startupwd);
setup_mygrowzone;{memory management}
setupmydebug;
{setup mainwindow centered on the screen}
centerit(wbounds,260,470);

mainwindow:=NewWindow(nil,wbounds,'Startup System Check',true,
        dboxProc,pointer(-1),false,0);
setport(mainwindow);
textfont(0);

mytextsetup;
initmypath(myRpath);
end;

procedure setup_buttons;
var i:integer;
    h,v:integer;
    cr,cmd:string[1];
    tag:str255;
begin
h:=12;
v:=210;
cr:=chr(13);
cmd:=chr(17);
for i:=1 to shutdownbut do
   with buttonrects[i] do
      begin
        top:=v;
        left:=h;
        right:=h+80;
        bottom:=v+38;
        h:=h+91;
      end;
h:=12;
v:=210;
for i:=shutdownbut+1 to mbutton do
   with buttonrects[i] do
      begin
        top:=v;
        left:=h;
        right:=h+80;
        bottom:=v+38;
        h:=h+91;
      end;

buttons[continuebut]:=NewControl(mainwindow,buttonrects[continuebut],
'Continue',false,0,0,1,PushButProc,0);

buttons[yesbut]:=NewControl(mainwindow,buttonrects[yesbut],'Yes',false,
             0,0,1,PushButProc,0);
tag:=concat(concat(concat('Halt',cr),cmd),'Q');
buttons[haltbut]:=NewControl(mainwindow,buttonrects[haltbut],tag,false,
             0,0,1,PushButProc,0);
buttons[nobut]:=NewControl(mainwindow,buttonrects[nobut],'No',false,
             0,0,1,PushButProc,0);
tag:=concat(concat('Shut',cr),'Down');
buttons[shutdownbut]:=NewControl(mainwindow,buttonrects[shutdownbut],tag,true,
             0,0,1,PushButProc,0);
tag:=concat(concat(concat(concat('System   ',cr),'   Only  '),cmd),'A');
buttons[sysonlybut]:=NewControl(mainwindow,buttonrects[sysonlybut],tag,true,
             0,0,1,PushButProc,0);
tag:=concat(concat('Application',cr),'Scan');
buttons[shortbut]:=NewControl(mainwindow,buttonrects[shortbut],tag,true,
             0,0,1,PushButProc,0);
tag:=concat(concat('Full    ',cr),concat(concat('Check ',cmd),'F'));
buttons[Fullbut]:=NewControl(mainwindow,buttonrects[fullbut],tag,true,
             0,0,1,PushButProc,0);
tag:=concat(concat(concat('Skip It',cr),cmd),'Q');
buttons[skipitbut]:=NewControl(mainwindow,buttonrects[skipitbut],tag,true,
             0,0,1,PushButProc,0);

end;{proc setup_buttons}
procedure in_progress_buttons;
begin
HiliteControl(buttons[continuebut],255);{make inactive but visible}
HideControl(buttons[sysonlybut]);
HideControl(buttons[shortbut]);
HideControl(buttons[fullbut]);
HideControl(buttons[skipitbut]);
ShowControl(buttons[continuebut]);
ShowControl(buttons[haltbut]);
ShowControl(buttons[shutdownbut]);
doevent(true);
end;
{$S          }
begin

initialize;
kill_nil;
setup_buttons;
allocate_big_memory;
start_types;
start_safekey;
doEvent(true);

HFSwarning;{quit if no HFS}

get_set_blessed;{set default to system folder}
Poststatus(blessedpath,pathline);
postmem(memline);

wait_for_start(
'This will take a minute or two to check the system folder and applications.'
,startupdelay);
in_progress_buttons;
WriteOutputFlag:=optionKeyFlag;{get state of option key from
                                button click or activate}
{look for input file}
open_input;
{ask about output file if option key down or input file not found}
if WriteOutputFlag or InputNotdefault then
   begin
   if ask('Do you want to write a new summary output file?',yesbut) then
      begin
       open_output;
       if writeoutputflag and fastapplcheck then
          fastapplcheck:=not Ask('Do you want a full checksum of applications',yesbut);
      end
   else
      begin
      writeoutputflag:=false;
      end;
    end
 else
    begin
    poststatus('(start with option key to write output file)',pathline);
    end;
read_input_header;
dovols;
readoklist;
{debugger;}
docheck;
if outputopen then skipapplcheck:=false;
if not skipapplcheck then docheck_applications;
summary;
if not skipapplcheck then
     APPLsummary
else
     copyAPPLSummary;

PostStatus('DONE',fileline);
sysbeep(1);
close_all_and_halt(false);
end.{color3d main}